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SECTION  1 

INTRODUCTION  AND  OVERVIEW 


HYPUF  is  a  stress  wave  response  code  that  has  the  ability  to  calculate 
ionization  effects  in  high  temperature,  high  density  plasmas.  As  such,  HYPUF  is  a 
derivative  of  the  PUFF-66  code.  HYPUF  is  also  a  public  domain  code  which  means  it 
is  freely  available  to  any  defense  contractor  having  a  need  to  calculate  the  response  of 
materials  to  radiation  induced  stress  waves. 

The  modifications  to  HYPUF  described  in  this  report  are  part  of  a  continuing 
program  to  provide  a  code  suitable  for  analysis  of  material  interaction  with  x-ray  lasers 
and  other  high  intensity  radiation  sources.  Previous  modifications  included  automatic 
zoning,  rezoning  and  spall  (fracture)  capabilities.  The  modifications  in  this  report 
include  elastic-viscoplastic,  Maxwell  dispersion,  and  Bade  geometric  dispersion 
material  response  models,  restructuring  of  the  code  to  facilitate  future  modifications 
and  numerous  minor  corrections  to  the  equation  of  state  and  ionization  equation  of 
state  subroutines. 

The  structure  of  the  remainder  of  this  report  is  as  follows:  Section  2  describes 
the  implementation  of  the  elastic-viscoplastic,  Maxwell  dispersion  and  Bade  geometric 
dispersion  material  response  models.  Section  3  describes  some  corrections  to  the 
ionization  equation  of  state  and  main  equation  of  state  subroutines.  These  corrections 
were  necessary  in  order  for  HYPUF  to  correctly  calculate  bound-bound  transitions  in 
high  Z  materials  such  as  gold  and  to  treat  hydrogen  bearing  materials.  Section  4 
describes  the  restructuring  of  the  code.  This  restructuring  was  done  to  facilitate 
implementation  of  a  P-a  material  response  model  for  distended  solids.  Section  5 
provides  recommendations  for  future  modifications  to  HYPUF. 
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SECTION  2 

MATERIAL  RESPONSE  MODELS 


This  section  describes  the  elastic-viscoplastic  Maxwell  dispersion  and  Bade 
geometric  dispersion  models  which  were  implemented  in  HYPUF.  All  three  models 
were  incorporated  as  closely  as  possible  to  the  way  they  were  implemented  in 
PUFF74.  The  only  differences  between  the  implementation  in  the  two  codes  was  that 
imposed  by  the  fact  that  HYPUF  is  a  temperature  based  rather  than  energy  based 
code  and  that  HYPUF  has  its  equation  of  state  package  completely  separate  from  the 
HYDRO  routine. 

The  elastic-viscoplastic  model  is  an  extension  of  the  elastic-plastic  model  which 
is  used  to  calculate  stress  deviators  in  solid  materials.  In  the  elastic-viscoplastic 

2 

model,  the  stress  deviator  can  overshoot  the  yield  surface  value  of  ^Y  (Y  =  yield 
strength).  The  stress  deviator  is  computed  incrementally  from  the  differential  equation. 

9SX  -§  £  ir>  |SX|  ^  |  Y 

_5r=[HI-t:(sx+!Ye)' 

In  equation  (1)  above,  the  parameters  are: 
v  =  Specific  volume 

\. l  =  Shear  modulus  which  is  calculated  from  its  initial  value  |i0  (input  as  AMU) 
based  on  the  assumption  that  the  ratio  of  shear  modulus  to  bulk  modulus  is 
constant 

Y  =  Yield  strength  which  is  calculated  from  the  input  parameters  Y0  (YO)  and 
YADD  as  a  function  of  plastic  strain 

Tr  =  Viscoplastic  relaxation  time  calculated  from  the  input  parameters  Tro 
(TRELAX)  and  Pr  (PRELAX). 

6  =  Dimensionless  parameter  of  magnitude  unity  and  opposite  in  sign  to  Sx. 

In  the  above  parameters,  Tr  is  calculated  from 


2 


r  (is  xh  -  |y)1 

Tf  =  Tro  *  exp  -  — 

'  r 


(2) 


The  ratio  of  shear  modulus  to  bulk  modulus  can  be  varied  upon  release,  thus 
controlling  the  shape  of  the  unloading  path.  This  is  controlled  by  the  dimensionless 
parameter  SHEARR.  Other  input  parameters  of  interest  are  EM,  the  melt  energy,  and 

YMU  the  compression  {Jf-  -  1  j  at  the  elastic  limit. 

These  parameters  are  used  as  described  in  Reference  1  and  Reference  5. 

The  Maxwell  dispersion  model  was  originally  designed  to  treat  geometric  dispersion  in 
layered  materials.  In  this  model,  a  second  stress  deviator  is  calculated  from  the 
equation 

4  ^2  3v  ^2 

~5T  =  3"v"7T  “  T~ 

r2  (3) 

Two  inputs  are  required.  They  are: 

P2  =  Effective  shear  modulus,  input  as  AMU2 
Tr2  =  Relaxation  time,  input  as  TRELX2 

The  Maxwell  dispersion  model  and  the  elastic-viscoplastic  model  may  be  used 
simultaneously.  In  that  case,  the  total  stress  in  the  solid  is  given  by 


Ox  =  P  -  Sx  -  S2  (4) 

Another  geometric  dispersion  model  available  is  the  Bade  geometric  dispersion 
model.  The  Bade  model  was  designed  to  describe  the  behavior  of  composites  such 
as  3DQP,  which  have  large  scale  heterogeneities.  In  this  model,  a  rate  dependent 
stress  is  calculated  from 
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Q  =  p0C2. 

0 

The  required  input  parameters  are  g>i  (input  as  OMEGA)  and  A  (input  as  EQSTA).  The 
Bade  model  can  also  be  used  in  conjunction  with  the  elastic  visco-plastic  model.  The 
total  stress  is  then 

Ox  =  P  -  Sx  +  Q  (6) 


2  d*U  2fl  du 

(D*  dndX  6), 
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SECTION  3 

CORRECTIONS  TO  EQUATION  OF  STATE 


During  the  process  of  implementing  the  changes  described  in  Section  2,  some 
difficulties  were  encountered  in  using  HYPUF.  These  difficulties  included  the  inability 
to  handle  hydrogen  bearing  compounds,  and  the  inability  to  handle  TWCP  or  similar 

materials  with  a  specific  heat  ratio  in  the  vapor  that  is  substantially  different  from  . 

In  addition,  Dr.  Judy  Gates  of  APTEK  (Reference  2)  discovered  that  HYPUF  did  not 
correctly  treat  the  bound-bound  transitions  of  high  Z  materials  such  as  gold.  This 
section  describes  the  actions  taken  to  correct  these  difficulties. 

The  errors  discovered  by  Dr.  Gates  involved  an  inconsistency  in  the  calculation 
of  bound-bound  transitions  and  the  possibility  of  a  floating  point  error  in  the  calculation 
of  the  energy  fraction  for  bound-bound  transitions  for  high  Z  materials.  In  order  to 
solve  these  problems,  several  changes  were  made.  To  correct  the  inconsistency  in 
the  number  of  bound-bound  transitions  which  can  be  treated,  the  dimensions  of 
NSAVE,  EBB,  and  NLEC  were  increased  as  shown  in  table  1  below.  In  addition,  the 
do-loop  on  index  NTMP  in  subroutine  OPAGUE  (see  Appendix  A,  page  A-85)  was 
changed  to  read: 

DO  870  NTMP  =  1 ,  15 
NTMP1  =16 -NTMP 
IF  (KI.LE.NLEC(N.NTMPI))  GO  TO  890 
870  CONTINUE 
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Table  1.  Change  in  dimensions  of  arrays  used  to  calculate 
bound-bound  transitions. 


Common 

Block 

Name 
or  Local 

Array 

Name 

Original 

Dimensions 

Corrected 

Dimensions 

AC 

EBB 

(10,  6,14) 

(10,  15,  14) 

AC 

NLEC 

(10,6) 

(10,  15) 

LOCAL* 

NSAVE 

(6) 

(15) 

*NSAVE  is  local  to  subroutine  GENRAT. 


In  subroutine  OPAGUE,  RBB  is  the  energy  fraction  for  the  bound-bound 
transition  of  interest.  Originally,  RBB  was  simply  divided  by  the  quantity  (EION  (N,  Jl)  - 
ENIK  (N,  K1 ,  K4))  in  a  loop  to  find  the  highest  active  edge  contributing  to  the  x-ray 
cross-section.  However,  in  certain  diabolical  situations,  there  are  no  electrons  being 
removed  from  subshell  K4.  In  such  a  situation,  (EION(N,JI)  -  ENIK  (N,  K1,  K4))  which  is 
the  edge  energy  for  removal  of  an  electron  from  subshell  K4,  will  be  zero  and  a 
floating  point  error  will  result.  To  correct  this  problem,  the  integer  array  NSNIK  (10,  8, 
14)  was  added  to  common  block  AC  and  the  following  additions  were  made  to  the 
coding:  An  inner  do  loop  was  added  after  the  inner  loop  to  initialize  NNIK  (see 
Appendix  A,  page  A-85): 

DO  550  K=1 ,  Kl 
KL  =  NOEC(N)  +  1  -K 
550  NNIK  (N,K1  ,KL)  =  NGRUP  (K) 

DO  560  K=  1,  14 

560  NSNIK  (N,K1  ,K)  =  NSPDF  (K) 
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Then  the  following  lines  of  code  were  added  (see  Appendix  A,  Page  A-86). 


1010  RBB  =  EBB  (N,  NTMP,  K4) 

KNN  =  KC  +  1  -  K4 

IF  (NSNIK  (N,  K1,  KNN) .  EQ.  0)  GO  TO  1020 
RBB  =  RBB/(EION(N,  Jl)  -  ENIK  (N,  K1 ,  K4)) 
1020  CONTINUE 


When  the  need  to  calculate  the  material  response  of  hydrogen  bearing 
materials  was  first  encountered,  the  code  would  not  cooperate.  Numerous  floating 
point  errors  made  it  necessary  to  alter  the  description  of  the  elemental  composition 
such  that  the  presence  of  hydrogen  was  ignored.  The  primary  source  of  these 
difficulties  was  traced  to  the  indexing  scheme  used  in  the  Saha  equation  solver  and 
related  sections  of  the  code.  The  Saha  equation  solver  is  an  indefinite  loop  designed 
to  calculate  the  degree  of  ionization  in  each  element  in  the  material.  Up  to  eight  levels 
of  ionization  and  the  population  fraction  for  each  of  the  levels  is  computed.  The  Saha 
equation,  however,  is  a  relationship  between  two  successive  levels  of  ionization. 

Thus,  the  Saha  equation  must  be  used  iteratively  to  find  the  eight  most  highiy 
populated  levels  of  ionization  and  the  fraction  of  the  population  in  each  level. 
According  to  Reference  6  the  ratio  of  particle  concentrations  between  the  mth  and  m  + 

1 st  ionization  levels  is  given  by 


a  ,a_ 
m+i  e 


a 


m 


1 

pN 


K  .  (T) 
m+l 


m  =  0, 1, 2... 


(7) 


where  ocj  =  Nj/N,  and 


U 


K  ,  (T)  =  2  • 
m+l '  ' 


m+1 


/"27imekT^ 


3/2 


U 


m 


e 


_  1  M+1 

kT 


Lam  =  1 


(8) 

(9) 
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Zmapp  =  cte 


(10) 


In  the  above  expressions,  Um  and  Um+i  are  the  electronic  partition  functions  of 
the  m  and  m+1  states,  me  is  the  mass  of  the  electron,  k  =  Boltzmann's  constant,  h  = 
Plank's  constant,  T  =  temperature  and  lm+i  is  the  ionization  potential  of  the  m-ion  (the 
increment  in  energy  needed  to  remove  the  m+1 st  electron).  For  hydrogen, 
a-)  =  ae  =1-a0,  and  so  equations  (7)  and  (8)  simplify  to 


1  -  a 


1 

pN 


(  2jcmek'n 


.  3/2 


1 

~TT 


(11) 


In  (1 1 )  a  is  the  population  fraction  of  the  first  ionization  level.  Thus,  in  order  to 
enable  HYPUF  to  handle  hydrogen,  two  changes  were  required:  First,  the  indexing 
scheme  was  altered  so  that  the  ground  state  or  zeroth  ionization  level  can  be  included 
in  the  calculations  where  appropriate.  Second,  the  analytical  solution  to  equation  1 1 
was  coded  into  the  Saha  equation  solver,  explicitly.  Since  the  ground  state  was 
included  in  the  eight  possible  levels  of  ionization  subroutine  FLOION  also  had  to  be 
modified  to  correctly  calculate  the  ionization  energy  in  the  material.  The  changes  in 
FLOION  were  (see  Appendix  A,  page  A-52) 


DO  60  K=1 ,  KN 
L  =  Nl  (K,  N) 

IF  (L.LE.O)  GO  TO  60 

El  (J)  =  El  (J)+R  (K,N)*EN  (N,  L)*AF  (M,N)*FLOAT  (NATOM  (M)) 
1  ‘9.632E1 1  /  XMW(M) 

IF  (J.NE.JTS)  GO  TO  60 

IF  (KPRIN.EQ.1)  WRITE  (6,190)  MATL  (M),  NAMEL  (N),  KN, 

1  L,  J,  El  (J),  R  (K,  N),  EN  (N,  L),  AF  (M,  N) 

60  CONTINUE 


In  SAHA,  the  changes  were  (see  Appendix  A,  page  A-116,  A-1 1 7): 
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c 

C  CHANGE  IN  KMAX  TO  INCLUDE  GROUND  STATE  AS  ONE  OF  THE 
C  POSSIBLE  IONIZATION  STATES 
C 

KMAX  (N)  =  MINO  (NTBL  (N)  +  1,8) 

KN  =  KMAX  (N) 


90  DO  150  N1  =  1,  NEM 
N  =  IELEM  (M,  N1) 

KN  =  KMAX  (N) 

KGO  =  KN  - 1 
IF  (KN.LE.  2)  GO  TO  100 
GOTO  110 
100  CONTINUE 

R  (1,  N)  -  0. 

A  (1,  N)  »  A  (1,  N )/ZST AR’ZST AR 1 

IF  (A(1 ,  N)  +  GT.  0.)  R  (1 ,  N)  =  0.5  *  A(1  ,N)*(SQRT  (1 .+  4./A(1  ,N»  - 1 .) 
IF  (A(1,  N) .  GT.  1.  .AND.  R(1,  N).EQ.0.)  R(1,  N)  =  1. 

RMAX  (N)  ts  R(1 ,  N) 

IF  (KPRIN.EQ.1.AND.  J.EQ.JTS)  WRITE  (6,240)  NAMEL  (N), 

1  ZSTAR,  ZSTAR1 ,  KN,  KGO,  A  (1  ,N) 

GO  TO  150 
110  CONTINUE 

DO  1 20  K  =  1 ,  KGO 


Also,  in  SAHA,  the  logic  to  designate  which  ionization  levels  are  of  interest  was 
changed  (see  Appendix  A,  page  A-118) 
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DO190N1  =  1,  NEM 
N  =  IELEM  (M,  N1) 

KN  =  KMAX  (N) 

IF  (KN.EQ.1)  GO  TO  190 


Once  the  changes  described  above  were  implemented  and  debugged,  an 

attempt  was  made  to  calculate  the  response  of  TWCP.  This  attempt  was  initially  met 

with  frustration  because  of  the  way  the  equation  of  state  routines  handle  expanded 

materials.  In  particular,  if  the  ratio  of  specific  heats  of  the  vapor  phase  is  substantially 
5 

different  from  3  ,  an  error  results.  Under  such  circumstances,  the  code  would  attempt 
to  converge  to  a  negative  temperature  which  was  not  allowed.  Consequently,  a 
negative  density  would  eventually  be  calculated  for  a  zone  and  a  math  error  would 
result  from  the  attempt  to  calculate  the  square  root  of  a  negative  number.  The 
correction  was  to  change  the  coding  in  EQST  (see  Appendix  A,  page  A-  42)  and  PE 
(see  Appendix  A,  pages  A-89  and  A-90).  In  EQST  the  corrected  coding  is: 


10  ALF  =  EQSTH  (M)  +  (EQSTG  (M)  -  EQSTH(M))  •  SORT  (ENU) 
IF  (ABS  (ALF  -  EQSTH  (M))  .LE.  1  .E-3)  GO  TO  20 
GO  TO  30 
20  W1  »1. 

GO  TO  40 

30  W1  =  2.*  (EQSTG(M)  -  ALF)/(ALF  -  EQSTH  (M)) 

W1  =(2.+W1)/(1.+W1) 

40  W2  =  1.5*  ALF*  W1 
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The  corrected  coding  in  PE  is  similar  to  that  in  EQST: 


50  ALF  =  EQSTH  (M)  +  (EQSTG(M)  -  EQSTH  (M))  *  SQRT  (ENU) 
IF  (ABS  (ALF  -  EQSTH  (M)) .  GT.  1  .E-3)  GO  TO  60 
W1  =1. 

GO  TO  70 

60  W1  =  2.*  (EQSTG(M)  -  ALF)/(ALF-EQSTH(M)) 

W1  =  (2.  +  W1  )/(1 .  +  W1 ) 

70  CONTINUE 


With  these  changes  HYPUF  can  now  treat  materials  with  any  reasonable  value  for  the 
ratio  of  specific  heats. 
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SECTION  4 
RESTRUCTURING 


In  order  to  simplify  the  task  of  implementing  a  P  -  a  material  response  model  or 
the  SESAME  tabular  equation  of  state,  it  was  decided  to  revise  the  structure  of 
HYPUF.  The  structure  of  HYPUF  at  the  beginning  of  this  effort  is  shown  in  Figure  1. 
The  final  structure  adopted  is  shown  in  Figure  2.  With  either  structure,  the  subroutine 
GEN  RAT  is  called  only  once  to  set  up  the  problem.  If  automatic  zoning  is  requested, 
GENRAT  calls  subroutine  A20NE,  and  AZONE  in  turn  calls  subroutine  FINDRZ. 
GENRAT  also  calls  subroutine  FLOION  to  initialize  the  x-ray  cross  sections  and 
determine  the  initial  deposition  profile.  Since  HYPUF  does  not  have  the  option  of 
using  an  arbitrarily  specified  deposition  profile,  FLOION  is  always  called  by  GENRAT. 
The  rest  of  the  subroutines  are  called  repeatedly  as  the  program  works  through  the 
solution  to  the  equations.  The  names  of  the  subroutines  give  a  reasonable  idea  of 
their  function.  It  is  noteworthy  that  subroutine  EQST  calls  subroutine  FLOION  to 
calculate  the  revised  x-ray  cross  sections  and  determine  radiation  and  thermal 
transport  through  the  materials.  In  addition,  subroutine  REZONE  calls  subroutine  EDIT 
only  if  the  debug  option  is  exercised. 

In  the  restructured  version  of  HYPUF,  certain  functions  originally  performed  in 
subroutines  EQST  and  FLOION  were  broken  out  into  separate  subroutines. 
Subroutines  PT  and  PE  were  broken  out  of  subroutine  EQST  in  order  to  facilitate  the 
implementation  of  a  P-a  model.  Subroutines  SAHA,  OPAGUE,  and  TRANSP  were 
broken  out  of  subroutine  FLOION  in  order  to  facilitate  the  implementation  of  the 
SESAME  or  other  tabular  equation  of  state. 

Subroutines  PT  and  PE  are  used  by  EQST  to  solve  for  the  new  pressure  and 
temperature  as  a  function  of  density  and  specific  energy.  Subroutine  PT  calls 
subroutine  PE  to  determine  pressure  and  energy  as  a  function  of  density  and 
temperature.  Subroutine  PT  uses  a  Newton  iteration  with  calls  to  PE  using  the  latest 
guess  at  the  correct  temperature  until  the  temperature  is  found  that  corresponds  to  the 
density  and  energy  calculated  by  subroutine  HYDRO.  For  each  value  of  temperature 
and  density  supplied  by  PT,  subroutine  PE  returns  the  corresponding  specific  energy 
and  pressure.  The  final  values  of  pressure  and  temperature  are  returned  by 
subroutine  PT  to  EQST. 
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Given  the  values  of  density  and  temperature,  subroutine  EQST  calls  subroutine 
FLOION  to  determine  the  transport  of  x-ray  energy  and  heat.  Subroutine  FLOION  now 
calls  subroutine  SAHA  to  determine  the  degree  of  ionization  in  the  material. 

Subroutine  SAHA  uses  the  Saha  equation  iteratively  to  determine  the  degree  of 
ionization.  FLOION  then  calls  subroutine  OPAGUE  to  determine  the  revised  electron 
structure  in  the  atoms  and  the  resulting  corrections  to  x-ray  cross  section.  FLOION 
then  calls  subroutine  TRANSP  to  determine  the  electron  thermal  conductivity  and 
Roseland  mean  opacity.  This  information  is  used  to  determine  the  transport  of  energy 
through  the  materials  of  interest  and  the  revised  deposition  profile. 

With  the  changes  described  above,  it  should  now  be  relatively  easy  to 
implement  a  P-a  model  for  distended  materials  and  a  tabular  equation  of  state  such  as 
SESAME.  For  distended  materials,  the  P-a  model  would  be  added  to  subroutine 
HYDRO.  Subroutine  HYDRO  could  then  call  subroutine  PE  iteratively  to  converge  on 
a  new  value  of  a  ( the  distension  parameter).  This  avoids  the  need  for  a  double 
iteration  in  the  P-a  (iteration  on  distension  and  iteration  on  temperature)  which  would 
otherwise  be  required. 

A  tabular  equation  of  state  model  could  be  used  in  place  of  subroutines  SAHA, 
OPAGUE  and  TRANSP  if  desired.  Such  a  tabular  equation  of  state  could  also  be  used 
to  replace  the  functions  of  subroutines  PE  and  PT.  Since  an  appropriate  tabular 
equation  of  state  might  not  exist  for  all  materials  of  interest,  the  use  of  the  present 
structure  of  HYPUF  should  make  it  possible  to  treat  combinations  of  materials  where 
some  materials  would  have  a  tabular  equation  of  state  and  other  materials  need  the 
analytical  equation  of  state. 
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HIRAD  -  BLOCK  DATA 
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igure  1.  Structure  of  HYPUF  at  beginning  of  effort. 


HIRAD  -  BLOCK  DATA 
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igure  2.  Revised  structure  of  HYPUF. 


SECTION  5 
RECOMMENDATIONS 


In  order  to  make  HYPUF  useful  for  calculating  the  stress  wave  response  of  solid 
propellant  booster  materials,  it  is  necessary  to  implement  some  type  of  P-a  model  for 
distended  materials.  Several  such  models  are  available,  the  simplest  P-a  known  to 
the  author  is  a  tabular  model  developed  by  M.  H.  Rice  of  S-Cubed.  The  P-a  model 
used  in  PUFF74  was  developed  by  ETI  (now  GRC).  In  addition,  there  are  some  more 
elaborate  models  which  have  been  developed  by  SRI  International  and  implemented 
in  SRIPUFF8.  As  a  first  step,  it  seems  most  reasonable  to  implement  as  simple  a  P-a 
model  as  possible  in  HYPUF.  If  subsequent  experience  demonstrates  a  need  for  a 
more  elaborate  model  for  distended  materials,  the  ETI  model  in  PUFF74  or  one  of  the 
SRI  models  in  SRIPUFF8  can  be  used. 

There  are  situations  in  which  the  present  analytical  equation  of  state  in  HYPUF 
is  not  adequate.  In  particular,  the  inability  of  the  equation  of  state  to  properly  treat  the 
behavior  of  liquids  and  the  melting  and  vaporization  phase  transitions  can  produce 
significant  errors  in  the  calculation  of  the  stress  wave  response  of  material  where  a 
large  fraction  of  the  material  is  melted.  The  simplest  way  to  eliminate  this  difficulty  is  to 
implement  a  tabular  equation  of  state  such  as  the  SESAME  package  developed  by 
Los  Alamos. 

Recently,  Dr.  Judy  Gates  of  APTEK  (Reference  3),  published  a  critique  of  the 
ionization  equation  of  state  in  HYPUF.  In  her  analysis,  Dr.  Gates  recommended  the 
use  of  the  Plank  mean  opacities  as  well  as  the  Rosseland  mean  opacities  for 
calculating  radiation  transport.  Such  a  modification  would  be  simplified  by  the  use  of 
the  SESAME  equation  of  state  since  SESAME  provides  both  the  Plank  and  Rosseland 
mean  opacities.  Therefore,  we  strongly  recommend  the  implementation  of  the 
SESAME  equation  of  state  in  HYPUF. 
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APPENDIX  A 

HYPUF  SOURCE  LISTING 


•COMDECK  BLANK 
C  BLANK  COMMON 

C 

COMMON  CS(201),  V(201),  E(201),  P(201),  S(201).  SD(201),  U(201), 

1  ZM( 201 ) ,  TEMPC201),  ZFMC201),  X(201),  Q(201),  Q0(201),  T0ZC201), 

2  DV( 201 ) .  EI(201 ) ,  ITER(201).  F(201),  F0(201),  EADD(201).  ZF(10,2C 

3  1),  88(201.5).  TEMP0( 201 ) ,  TKEEP(201),  ET(201).  PN(201),  XFX(201) 

4  .  XFL( 201 ) 

C 

COMMON  AMU(6) ,  CUSP1(6).  CUSPA(6),  CUSPC(6),  CUSPD(6).  CUSPG(6) . 

1  COSPS(6),  EQSTCC6),  EQSTD(6) ,  EQSTS(6) ,  EQSTEC6) .  EQSTG(6) ,  EQSTH 

2  (6),  EQSTNC6),  RH0(6) ,  PMIN(6).  LGDEL(6) ,  YADD(6),  YMO(6),  Y0(6). 

3  JBND(6),  NELEMC6),  XMV(6),  IELEM(6,5),  AF(6,10),  XAW(IO),  NOE(IO) 

4  ,  NTBL(IO),  XI(IO.IOO),  EN(IO.IOO),  cJEDIT(lO),  JORG(IO).  TEDITC 25 

5  ).  NZ(20),  RZ(20) ,  T(3),  EE(3),  START(3) ,  SST0P(3),  NBB( 3) ,  NKNU( 

6  3),  ES(3 , 109) .  AA( 10,25),  B(10.25).  EDGE(10,25),  NAT0M(6) ,  XC0N(6 

7  ) 

C 

COMMON  CKS ,  CO.  Cl.  DTN,  DTNH,  IT.  JCYCS ,  JFIN,  JSMAX,  JSMAXI , 

1  JRZL ,  JSTAR.  JTS ,  JZPUL,  LINE.  LOZHIZ,  N.  N JEDIT ,  IMTRLS ,  NPRIN , 

2  NREZON.  NRZ .  NSPEC.  NTAPE ,  NTEDT ,  PDTNEG ,  PDTPOS ,  SDURM,  SK2M . 

3  SMAX.  SSTOPM ,  TIME,  TS .  WTAPE.  ILIN ,  ILOG,  ICON,  IDIF .  ANGLE. 

4  DTMIN ,  DIFTST,  DTPRIM,  IFLOW,  «JHAT,  NCOUNT,  NDEP,  JPRIN,  ION, 

5  NDBG,  TR 
C 

C  CHARACTER  STATEMENTS 
C 

CHARACTER  *10  DISCPT,  MATL,  NAMEL 
C 

COMMON  ,/CHARB/  DISCPT(8),  MATL(6) ,  NAMEL(IO) 

C 

•COMDECK  AA 

COMMON  /AA/  ITBL(96 ,6) ,  ILTBL1(3),  ILTBL2(3),  ILTBL3(3),  ILTBL4(1) 

1  ,  ILTBL5( 3) ,  ITABLC19),  XNSTARC 14) ,  TBL( 109) ,  SCALE(18),  SCAX(15) 

2  ,  JTABL( 14) 

C 

‘COMDECK  AB 

COMMON  /AB/  ICHCK 
C 

•COMDECK  AC 

COMMON  /AC/  NOEC(IO),  EDGEC( 10 . 20 ) ,  EI0N(  10 . 100 ) ,  SCREN0( 10 , 20)  . 

1  NGRUP( 19) ,  NSUM( 19) ,  NSPDF(14),  NVARM(6) ,  NVARE(IO),  NI0N(10.19), 

2  EBB( 10,15,14),  NLEC( 10,15),  NSNIK( 10 , 8 , 14) 

C 

•COMDECK  EQED 

COMMON  /EQED/  RERAD 
C 

•COMDECK  EQFL 

COMMON  /EQFL/  ALF ,  ARG,  ARGEXP ,  DEDT,  DEDTP,  DELRO,  DES1 .  DFDT, 
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HYPUF  SOURCE  LISTING 


1  DPDRC ,  DPDT ,  DPDTP ,  DTRC,  DTRCl .  DU,  DXY1 ,  DXY2 ,  DXZ,  EMU,  ENU . 

2  ENU2,  ESI,  ESIN.  ES10,  EXPR,  FXPC,  IPLUS(IO),  IPLUSO(IO),  ITRT, 

3  KGO.  KMAX(IO).  KN .  NEM,  NIC8.10),  R(8,10).  SK2M1 ,  TEMPJ ,  TREF ,  VI 

4  ,  Wl,  W2 ,  XITMP,  XLAM1C201),  XLAM2(201),  XMAX ,  XMAX1 .  XNATOM .  XN1 

5  ,  XP,  XTEV ,  XX.  XXX.  XY1 ,  XY2 ,  XZ.  XZ2 .  ZFl(lO),  ZSTAR,  ZSTAR1 , 

6  Zl.  Z2 
C 

*COMDECX  EQVP 

COMMON  /EQVP  '  AMU2(6),  CH(6)  .  EQSTA(6) ,  GOKE(6),  G0K£2(6) ,  GOVERK( 

1  201),  JB(6) ,  MFLAGC6).  0MEGAC6) ,  PRELAX(6),  QU(201),  SD2(201), 

2  SH£ARR(6) ,  TRELAX ( 6 ) ,  TRELX2(6) ,  VAMUC201 ) ,  YYC201),  ZZ(201) 

C 

•COMDECK  HYEQ 

COMMON  /HYEQ/  JTRY 
C 

*COMDECK  XNDX 

COMMON  / INDX/  I,  ICOUNT,  IGO,  J.  JCOUNT,  J1 ,  J2 .  X.  KCOUNT,  KPRIN , 
1  L.  LL,  M.  MCOUNT,  NKEEP ,  NC.  NCHNG,  NTMP ,  NTMP1 ,  N1 
C 

•COMDECK  PEPT 

COMMON  /PEPT/  ARGTST .  EH,  FSAVE1 ,  FSAVE2 .  FTMP ,  FTMP1 ,  FTNEW, 

1  FTHE1.  PH,  SAVE1,  SAVE2 ,  SAVE3 ,  TMAX,  TMIN ,  TNEW ,  XLTP1 ,  XLTP2 , 

2  XLTP3 
C 

C  COMMON  /PEPT/  IS  DESIGNED  TO  FAKE  OUT  THE  FTN5  COMPILER  IN  OPT. 2 

C  MODE.  THESE  VARIABLES  ARE  NEEDED  ONLY  IN  SUBROUTINES  PE  AND  PT, 

C  BUT  BY  PLACING  THEM  IN  A  LABELLED  COMMON  WE  FORCE  THE  COMPILER  TO 

C  RETAIN  THEIR  VALUES  AFTER  LAST  USE  FOR  REUSE  IN  SUBSEQUENT 

C  CALLS  TO  THE  SUBROUTINE. 

C 

•COMDECK  PLOTCM 

COMMON  /PLTCM/  DSTF(IO),  MTLN(IO),  PSMAX(201),  PSMIN(201),  PX(201) 
1  ,  SQJ(IO) 

C 

COMMON  / PLTCH/  MM(6) 

CHARACTER  *10  MM 
C 

•COMDECK  RZCOM 

COMMON  /RZCOM/  RZC1 ,  RZCO ,  RSCRIT 
C 

*  COMDECK  SPLLC 
C  SPALL  VARIABLES 

C 

COMMON  /SPLLC/  EM(6),  IS,  ISM,  ISPALL,  ISPLLM(6),  JS .  JTMAX,  MS, 

1  SJ,  SM( 50) ,  TMAX,  TSPALL(201),  US(50).  XS(50) 

C 
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HYPUF  SOURCE  LISTING 


•DECK  HIRAD 

PROGRAM  HIRAD 
C 

•IF  DEF.B32 

IMPLICIT  DOUBLEPRECIS ION(A-H.O-Z) 

•ENDIF 


THIS  COMPUTER  PROGRAM  CALCULATES  THE  HYDRO  OR  ELASTIC-PLASTIC 
MOTION  OF  UP  TO  SIX  MATERIAL  LAYERS.  EACH  MATERIAL  MAY  INCLUDE 
UP  TO  5  ELEMENTS  WITH  THE  TOTAL  NUMBER  OF  ELEMENTS  PER  PROBLEM 
LIMITED  TO  10. 

THE  PROGRAM  CAN  ACCOMODATE  UP  TO  3  X-RAY  SOURCES. 

THE  X-RAY  ABSORPTION  CROSS-SECTIONS  OF  THE  ELEMENTS  MAY  BE 
VARIABLE  (DEPENDENT  ON  IONIZATION)  IF  DESIRED. 

IF  THE  CROSS-SECTION  OF  AN  ELEMENT  IS  VARIABLE  THE  PROGRAM 
CALCULATES  THE  NUMBER  OF  X-JJfcY  ABSORPTION  EDGES  THE  ATOM 
HAS  AND  THE  ENERGY  OF  THE S E-^EDGES .  IT  ALSO  CALCULATES  THE 
IONIZATION  POTENTIALS  FOR  ZERO  TO  COMPLETE  IONIZATION  AND  THE 
IONIZATION  ENERGY  OF  ALL  THE  POSSIBLE  IONIZATION  STATES.  IF  10 
EQUALS  1.  IT  IS  ASSUMED  IN  THESE  CALCULATIONS  THAT  THE  STABLE 
CONFIGURATION  OF  THE  ELECTRONS  REMAINING  AT  ANY  IONIZATION 
STATE  IS  LIKE  THAT  OF  A  NEUTRAL  ATOM  CONTAINING  AS  MANY  PROTONS 
AS  THE  ION  HAS  ELECTRONS.  IF  ION  EQUALS  ZERO.  THE  ELECTRON 
CONFIGURATION  REMAINS  LIKE  THAT  OF  THE  ORIGINAL  NEUTRAL  ATOM 
AND  ELECTRONS  ARE  REMOVED  FROM  THE  OUTSIDE  SUB-SHELLS  FIRST, 
WORKING  INWARD  AS  IONIZATION  PROGRESSES. 

EIGHT  LEVELS  OF  IONIZATION  (OR  ALL  POSSIBLE  ONES  IF  Z  IS  LESS 
THAN  8)  ARE  ALLOWED  IN  THE  IONIZATION  CALCULATIONS. 

THE  RELATIVE  NUMBER  OF  PARTICLES  IN  THE  LEVELS  ARE  DETERMINED 
BY  THE  IONIZATION  POTENTIALS  OF  THE  LEVELS. 

CONDUCTION  MAY  BE  ALLOWED  IN  SOLID  MATERIALS  —  CONDUCTION  AND 
DIFFUSION  MAY  BE  ALLOWED  IN  VAPORIZED  MATERIALS. 

THE  EQUATION  OF  STATE  SUBROUTINE  OF  THIS  PROGRAM  CALCULATES 
NEW  TEMPERATURES  BY  MAKING  SUCCESSIVE  GUESSES  AT  ALL  ACTIVE 
ZONE  TEMPERATURES  USING  THE  NEWTON  METHOD. 

THIS  PROGRAM  HAS  BEEN  SUPPLIED  WITH  A  LINE  PRINTER  PLOTTING 
ROUTINE  WHICH  OUTPUTS  BOTH  LOGARITHMIC  AND  LINEAR  PLOTS  WHEN 
AND  IF  DESIRED  FOR  EASY  AND  QUICK  INTERPRETATION  OF  PROBLEM 
RESULTS . 
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HYPUF  SOURCE  LISTING 


DIAGNOSTIC  PRINTOUTS  OF  IONISATION  CALCULATIONS,  ENERGY 
FLUXES,  AND  DEPOSITION  OF  ENERGY  IN  THE  ZONES  IS  EASILY 
CONTROLLED  USING  THE  INPUT  VARIABLES  NPRIN  AND  JPRIN. 

EVEN  THOUGH  THE  PUFF-66  CODE,  FROM  WHICH  HIRAD  WAS  DERIVED,  DID 
NOT  CONFORM  TO  USASI  FORTRAN  PROGRAMMING  STANDARDS,  THE  HIRAD 
CODE  HAS  BEEN  MADE  TO  COMPLY  WITH  THESE  STANDARDS.  THIS  HAS 
FORCED  THE  ELIMINATION  OF  SCRATCH  TAPE  6,  SINCE  THIS  TAPE  IS  US 
FOR  PRINTED  OUTPUT.  SCRATCH  TAPE  4  WAS  ELIMINATED  AT  THE  SAME 
TIME,  SINCE  THE  EDITING  PROGRAM  USED  FOR  PUFF -66  WOULD  NOT  HAVE 
BEEN  DIRECTLY  APPLICABLE  TO  HIRAD,  ANYWAY.  IT  IS  FELT  BY  THE 
AUTHORS  THAT  THE  EDITING  CAPABILITIES  INCORPORATED  IN  HIRAD  ARE 
MORE  THAN  SUFFICIENT  TO  INFORM  THE  USER  OF  PROBLEM  RESULTS,  THU 
MAKING  TAPES  4  AND  6  NOT  NECESSARY. 


VARIABLES  IN  BLANK  COMMON  AND  THEIR  USAGE 
SUBSCRIPT  -J-  REFERS  TO  ZONE 

SUBSCRIPT  -M-  REFERS  TO  MATERIAL  (EITHER  COMPOUND  OR  ELEMENT) 
SUBSCRIPT  -N-  REFERS  TO  ELEMENT 
SUBSCRIPT  -L-  REFERS  TO  ENERGY  SOURCE 
SUBSCRIPT  -NS-  REFERS  TO  SPECTRUM 

ZONE  VARIABLES 

SOUND  SPEED  IN  CM/ SECOND 
SPECIFIC  VOLUME  IN  CC/GRAM 
SPECIFIC  ENERGY  IN  ERGS/GRAM 
PRESSURE  IN  DYNES/CM* «2 
STRESS  IN  DYNES/CM* *2 
STRESS  DEVIATOR  IN  DYNES/CM* *2 
PARTICLE  VELOCITY  IN  CM/ SECOND 
ZONE  MASS  IN  GRAMS/CM* *2 
TEMPERATURE  IN  KELVIN  DEGREES 
IONIZATION  IN  MATERIAL 
ZONE  BOUNDARY  POSITION  IN  CM 

ARTIFICIAL  VISCOSITY  FOR  CURRENT  TIME  STEP  IN 
DYNES /CM*  *2 

ARTIFICIAL  VISCOSITY  FOR  PREVIOUS  TIME  STEP 
YIELD. STRENGTH  OF  MATERIAL  IN  DYNES/CM**2  (IN 
THIS  ZONE) 

CHANGE  IN  SPECIFIC  VOLUME  DURING  CURRENT  TIME 
STEP 

ENERGY  USED  IN  IONIZATION  IN  THIS  ZONE 
A  FLAG  SET  UP  IN  SUBROUTINE  EQST  TO  INDICATE  TO 
SUBROUTINE  FLOION  NO  CALCULATION  OF  CONDUCTION 
OR  DIFFUSION  FLUX  INTO  THIS  ZONE  IF  ITER  EQUALS 


CS(J) 

V(J) 

E(J) 

P(J) 

S(J) 

SD(  J  ) 
U(J) 

ZM(  J) 
TEMP ( J ) 
ZFM (J) 
X(J) 
Q(J) 

QO(J) 
YOZ( J ) 

DV(  J) 

El  (  J) 
ITER( J ) 
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HYPUF  SOURCE  LISTING 


F(J) 
FOCJ) 
EADD(J) 
ZF(N, J) 
SS( J ,L) 


XFX(J) 

XFL(J) 

MATERIAL 

AMU(M) 

YMU(M) 


YADD(M) 

YO(M) 


EQSTC(M) 

EQSTD(M) 

EQSTS(M) 

EQSTG(M) 

CUSPl(M) 

CUSPA(M) 


CUSPC(M) 

CUSPD(M) 

CUSPSCM) 

CUSPG(M) 


EQSTH(M) 

EQSTN(M) 

EQSTE(M) 


ZERO,  A  CONDUCTION  ONLY  CALCULATION  IF  ITER 
EQUALS  1.  A  DIFFUSION  ONLY  CALCULATION  IF  ITER 
EQUALS  2.  AND  A  DIFFUSION  AND  CONDUCTION 
CALCULATION  IF  ITER  EQUALS  S. 

IF  ITER  EQUALS  4  NO  ENERGY  TRANSFER  IS  ALLOWED 
THE  ENERGY  FLUX  INTO  A  ZONE  IN  ERGS / CM  *  *  2 / SECOND 
DURING  THE  CURRENT  TIME  STEP 

THE  ENERGY  FLUX  CALCULATED  DURING  THE  PREVIOUS 
CYCLE 

THE  ENERGY  ADDED  TO  THIS  ZONE  DURING  THE 
CURRENT  TIME  STEP  IN  ERGS /GRAM 
THE  IONIZATION  IN  ELEMENT  N  IN  ZONE  J  DURING 
THE  CURRENT  TIME  STEP 

THE  CURRENT  VALUE  OF  THE  ENERGY  DEPOSITION 
RATE  IN  ERGS /GRAM/ SECOND  FOR  ZONE  J  DUE  TO 
SOURCE  L 

X-RAY  FLUX  (CAL/SQ  CM/ SEC) 

X-RAY  FLUENCE  (CAL/SQ  CM) 

VARIABLES 

THE  SHEAR  MODULUS  OR  MODULUS  OF  RIGIDITY 
THE  COMPRESSION  WHICH  CORRESPONDS  TO  THE  ELASTIC 
LIMIT,  I.E.  PLASTIC  FLOW  OCCURS  BEYOND  THIS 
COMPRESSION. 

THE  INCREASE  IN  YIELD  STRENGTH  WHICH  OCCURS 
DURING  COMPRESSION  FROM  YMU(M)  TO  0.2 
THE  ROOM  TEMPERATURE  ZERO  COMPRESSION  YIELD 
STRENGTH 

SOLID  EQUATION  OF  STATE 
CONSTANTS  USED  IN  THE  EQST  — 

P-(C*MU+D*MU*  *2+S*MU*  *3) * ( 1 . -G*MU/2 . )+G*RHO*E 
WHERE  MU  -  ( RHO / RHOO ) - 1 . 

THE  VALUE  OF  THE  PRESSURE  AT  WHICH  AN  INFLECTION 
OCCURS  IN  THE  HUGONIOT  DATA 
THE  VALUE  OF  WU-(RHO/RHOO)-1 .  AT  WHICH  THE 
INFLECTION  OCCURS 

SOLID  EQUATION  OF  STATE  CONSTANTS  USED  AT 
COMPRESSIONS  BEYOND  THE  INFLECTION  POINT  IN 
THE  EQST  --  P-(CUSP1+CUSPC*(MU-CUSPA)+CUSPD* 

( MU-CUSPA ) *  *  2+CUSPS  * (MU-CUSPA ) *  *  3 ) * ( 1 . -CUSPG* 
MU/2. )+CUSPG*RHO*E 

VAPOR  PHASE  EQUATION  OF  STATE  CONSTANTS  USED 
IN  THE  EQST  —  P-RHO* ( EQSTH+C EQSTG-EQSTH) * 

ETA*  *0 . 5 ) * ( E-EQSTE* ( 1 . -EXP( EQSTN/ETA* ( 1 . - 
l./ETA))))  WHERE  ETA -RHO /RHOO  AND  EQSTE  IS 
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SUBLIMATION  ENERGY,  EQSTH  IS  SPECIFIC  HEAT 
RATIO  -  1.  EQSTN  IS  EQSTC/ (EQSTG*EQSTE*RHO) 


MATL(M) 

RHO(M) 

NELEM(M) 

NATOM(M) 

XMW(M) 

LGDEL(M) 


XCON(M) 

PMIN(M) 

JBND(M) 

IELEM(M.N) 

AF(M,N) 


THE  NAME  OF  THE  MATERIAL 
THE  ZERO-PRESSURE  DENSITY 

THE  NUMGER  OF  ELEMENTS  OCCURING  IN  THE  MATERIAL 
THE  NUMBER  OF  ATOMS  IN  A  MOLECULE  OF  THIS  MATL . 
THE  MOLECULAR  WEIGHT  OF  THIS  MATERIAL 
A  MATERIAL  CONSTANT  USED  IN  CALCULATING  THE 
CONDUCTIVITY  AS  —  CONDUCTIVITY- 1 . 27E-5/ 

AVERAGE IONIZATION/ LGDEL  *  TEMPERATURE  * *2 . 5 
( ERGS / DEGREE / CM / SECOND ) 

THE  THERMAL  CONDUCTIVITY  OF  THE  NEUTRAL  ATOMIC 
CONFIGURATION  OF  THIS  MATERIAL 

THE  SMALLEST  PRESSURE  (LARGEST  TENSION)  ALLOWED 
IN  A  MATERIAL 

THE  LAST  ZONE  IN  A  MATERIAL  EXCEPT  IF  IT  IS  THE 
RIGHT  MOST  MATERIAL,  WHEN  JBND  -  0 
THE  NUMBER  DESIGNATION  OF  THE  ELEMENTS  (N) 
OCCURING  IN  MATERIAL  M 

THE  ATOM  FRACTION  OF  THE  ELEMENTS  IN  THIS  MATL. 


ELEMENT  VARIABLES 


NAMEL(N) 

XAW(N) 

NTBL(N) 

NOE(N) 

XI(N.IOO) 

EN(N, 100) 


ELEMENT  NAME 
ATOMIC  WEIGHT 
ATOMIC  NUMBER 

NUMBER  OF  X-RAY  ABSORPTION  EDGES 
THE  IONIZATION  POTENTIALS 
IONIZATION  ENERGIES 


AA(N ,25)  ELEMENT  CONSTANTS  USED  IN  CALCULATING  X-RAY 

B(N ,25)  ABSORPTION  --  ABSORPTION  COEFFICIENT-  AA* 

PHOTON  ENERGY* *B  IF  PHOTON  ENERGY  GREATER  THAN 
EDGE. 


SOURCE  VARIABLES 


NBB(NS) 

T(L) 

EE(L) 

NHNU(L) 

START (NS) 
SSTOP(NS) 
ES(L, I ) 


NUMBER  OF  SOURCES  IN  THIS  SPECTRUM  (AS  MANY  AS 
3  BLACXBODIES  OR  ONE  ARBITRARY  SOURCE) 

THE  BLACXBODY  TEMPERATURE  (-1.  FOR  ARBITRARY 
SOURCE) 

THE  STRENGTH  (CAL/CM**2) 

NUMBER  OF  ENERGY  INTERVALS  (SET  TO  ZERO  FOR 
BLACXBODY) 

TIME  OF  BEGINNING  OF  SHINE 
TIME  OF  END  OF  SHINE 

ENERGY  REMAINING  IN  ENERGY  INTERVAL  I  OF 
SPECTRUM  NS  OR  BLACXBODY  L  (USED  IN  CALCULATION 
OF  ENERGY  DEPOSITION) 
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ZONING  VARIABLES 


RZ( A)  GEOMETRIC  RATIO  OF  ZONE  SIZES 

NZ( A)  NUMBER  OF  THE  LAST  ZONE  USING  RATIO  RZ(A) 

PROBLEM  CONTROL,  OUTPUT  CONTROL,  AND  MISCELLANEOUS  VARIABLES 


DISCPT  PROBLEM  DESCRIPTION 

JEDIT  ZONE  NUMBER  WHERE  LA GRAN GIAN  EDIT  IS  DESIRED 

JORG  NOT  USED 

TEDIT  PROBLEM  TIME  IN  SECONDS  WHERE  EDITS  ARE  DESIRED 

CKS  WHEN  PEAK  PRESSURE  REACHES  THIS  DEPTH,  PROBLEM 

IS  STOPPED. 


CO 

Cl 


DTN 

DTNH 

IT 

JCYCS 

JFIN 

JSMAX 

JSMAXI 

JRZL 

JSTAR 

JTS 

JZPUL 

LINE 

LOZHIZ 

N 

NJEDIT 

NMTRLS 

NPRIN 

NREZON 

NR  2 

NS  PEC 
NTAPE 

NTEDIT 


1.8 

0.25 

USED  IN  CALCULATION  OF  ARTIFICIAL  VISCOSITY  — 
QNEW«(DU**2*CO**2-C1*CS*DU)*RHO(AVE)  WHERE 
RHO(AVE)  -  0 . 5* ( RHO(OLD)+RHO(NEW) ) 

0 . 5* C DTNH ( OLD )+DTNHC NEW) ) 

CURRENT  TIME  STEP  (SECONDS) 

VARIABLE  USED  TO  CALL  TIME  EDITS 

MAXIMUM  NUMBER  OF  CYCLES  IN  PROBLEM 

ZONE  BOUNDARY  NUMBER  OF  LAST  ZONE  IN  PROBLEM 

THE  NUMBER  OF  THE  ZONE  WITH  THE  LARGEST  STRESS 

USED  TO  DETERMINE  IF  REZONE  IS  DESIRABLE 

ZONES  COMBINED  IF  MORE  THAN  JRZL  MEET 

QUALIFICATIONS 

THE  DEEPEST  CURRENTLY  ACTIVE  ZONE 

THE  ZONE  CONTROLLING  THE  TIME  STEP 

NUMBER  OF  ZONES  DESIRED  IN  FRONT  OF  PRESSURE 

PULSE 

NUMBER  OF  LINES  PRINTED  ON  CURRENT  OUTPUT 
RECORD  —  USED  TO  CALL  NEW  PAGE. 

A  FLAG  SET  TO  ONE  FOR  A  TWO-PULSE  PROGLEM 
CURRENT  HYDRO -CYCLE  NUMBER 
NUMBER  OF  LAGRANGIAN  EDITS 
NUMBER  OF  MATERIALS  IN  PROBLEM 

EDITS  ARE  CALLED  FOR  EACH  NPRIN  HYDRO-CYCLES  — 
ALSO,  DIAGNOSTIC  DATA  IS  PRINTED  IF  JPRIN-1 
REZONE  CAN  BE  ENTERED  ONLY  ON  MULTIPLES  OF 
NREZON  CYCLES 

THE  ZONES  IN  THE  DIVIDE  AREA  OF  REZONE  EXTEND  TO 
JSMAX-fNRZ 

THE  NUMBER  OF  SPECTRA  IN  THIS  PROBLEM 
DATA  DUMPS  ON  TAPE  OCCUR  AT  CYCLES  WHICH  ARE 
MULTIPLES  OF  NTAPE 
NUMBER  OF  TIME  EDITS  DESIRED 


A-7 


oonooooooooooooonoooooooooooooooonooooooooonooonoo 


HYPUF  SOURCE  LISTING 


PDTNEG 

PDTPOS 

SDURM 

SK2M 

SMAX 

SSTOPM 

TIME 

TS 

WTAPE 

ILIN 

I  LOG 

ICON 

IDIF 

ANGLE 

DTMIN 

DTPRIM 

I  FLOW 

JHAT 

NCOUNT 

NDEP 

JPRIN 


INTEGRATED  NEGATIVE  MOMENTUM  (DYNE- SECOND/ CM*  *2) 
IN  THE  DEEPEST  JEDIT  ZONE 

INGEGRATED  POSITIVE  MOMENTUM  IN  DEEPEST  JEDIT 
ZONE 

THE  MINIMUM  DURATION  OF  CURRENTLY  ACTIVE  SPECTRA 
—  USED  IN  CALCULATION  OF  MAXIMUM  HYDRO  TIME 
STEP  ALLOWED 

MAXIMUM  TIME  STEP  ALLOWED  FOR  STABILITY  OF  HYDRO 
MOTION 

MAXIMUM  ABSOLUTE  VALUE  OF  STRESS 

THE  TIME  AT  WHICH  ALL  SOURCES  HAVE  STOPPED 

RADIATING 

CURRENT  PROBLEM  TIME  (SECONDS) 

INPUT  STOP  TIME  FOR  PROBLEM 
A  FLAG  —  IF  EQUAL  I,  RESTART  VARIABLES  ARE 
WRITTEN  ON  TAPE 

IF  0.  LINEAR  PLOTS  ARE  MADE  ON  PRINTER  EVERY 
NPRIN  CYCLES 

IF  ZERO,  LOG  PLOTS  ARE  MADE  BY  PRINTER  EVERY 
NPRIN  CYCLES 

IF  ZERO.  CONDUCTIVITY  IN  SOLID  MATERIALS  IS 
ASSUMED 

IF  ZERO,  DIFFUSION  OF  ENERGY  IN  MATERIALS  IS 
ASSUMED 

THE  ANGLE  IN  STERADIANS  AT  WHICH  THE  SOURCES 
RADIATE  ON  THE  MATERIAL 
AN  INPUT  VARIABLE  WHICH  DETERMINES  THE 
ACCURACY  TO  WHICH  TEMPERATURES  MUST  BE 
CALCULATED  BY  THE  EQST  ROUTINE 
THE  SMALLEST  TIME  OVER  ALL  ZONES  IN  WHICH 
THE  ENERGY  WILL  BE  ALTERED  BY  1  PERCENT,  DUE 
TO  ENERGY  TRANSFER  WITH  ITS  NEIGHBORING  MESHES. 

A  FLAG  TO  INDICATE  TO  THE  FLOION  SUBROUTINE  THAT 

CONDUCTION  AND/OR  DIFFUSION  RATES  SHOULD  BE 

RE-CALCULATED  THIS  CYCLE 

THE  DEEPEST  ZONE  AT  WHICH  IONIZATION 

NEEDS  TO  BE  CALCULATED 

A  COUNT  OF  THE  TOTAL  NUMBER  OF  GUESSES  REQUIRED 
BY  THE  EQST  SUBROUTINE  (ONE  GUESS  INCLUDES  A  NEW 
TEMPERATURE  IN  EACH  ACTIVE  ZONE)  TO  FIND 
CORRECT  TEMPERATURES 

AN  INPUT  CONSTANT  -  ENERGY  DEPOSITION  IN  THE 
ZONES  IS  RECALCULATED  EVERY  NDEP  CYCLES 
AN  INPUT  CONSTANT  -  SET  EQUAL  TO  1 .  IT  CALLS 
FOR  DIAGNOSTIC  PRINTOUT  AT  MULTIPLES  OF  NPRIN 
CYCLES.  JPRIN  CAN  ALSO  BE  SET  TO  THE  CYCLE 
NUMBER  AT  WHICH  DELAYED  DIAGNOSTIC  PRINTOUT 
IS  TO  BEGIN.  IF  JPRIN  IS  SET  TO  A  NUMBER 
GREATER  THAN  ONE,  DIAGNOSTIC  OUTPUT  FROM 
SUBROUTINE  GENRAT  IS  PRINTED  OUT  AND  THEN 
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ION 


ITBL(Z,6) 
ILTBL1 (3) 
ILTBL2(3) 
ILTBL3(3) 
ILTBL4C 1 ) 
ILTBL5C3) 


ITABLC 19) 
JTABLC14) 


XNSTAR(14) 

TBLC109) 


SCALE (18) 
SCAX( 15) 


ICHCK 


ONLY  THE  DIAGNOSTICS  FOR  NCYCL  GREATER  THAN 
JPRIN 

AN  INPUT  CONSTANT  -  SET  EQUAL  TO  1  IT  CALLS  FOR 
ELECTRON  RE-ARRANGEMENT  DURING  IONIZATION. 

LEFT  EQUAL  TO  ZERO  ELECTRONS  ARE  REMOVED  FROM 
OUTSIDE  SUB-SHELLS  WITH  NO  RE-ARRANGEMENT  OF 
INNER  SHELLS. 

VARIABLES  IN  COMMON  BLOCK  /AA/ 

THESE  SIX  TABLES  ARE  USED  TO  FIND  THE  NORMAL 
ELECTRON  STRUCTURE  OF  THE  ELEMENTS  THROUGH 
Z-96 .  ITABCZ.6)  CONTAINS  THE  NUMBER  OF 
ELECTRONS  IN  THE  LAST  1  TO  6  SUB-SHELL  GROUPS  - 
S.  P,  D,  AND  F.  ILTBL1  THROUGH  ILTBL5  CONTAIN 
THE  NUMBER  OF  ELECTRONS  IN  THE  1  TO  13  SUB-SHELL 
GROUPS. 

THE  19  POSSIBLE  SUB-SHELL  GROUPS  ARE  COMPACTED 
INTO  14  GROUPS  IF  THE  S  AND  P  SUB-SHELLS  ARE 
COMBINED  FOR  CONVENIENCE  IN  CALCULATING 
SCREENING  CONSTANTS  AND  ATOM  OR  ION  ENERGIES. 
ITABL  GIVES  THE  GROUP  NUMBER  IN  THE  COMPACTED 
GROUP  (1  TO  14)  INTO  WHICH  EACH  OF  THE 
SUB-SHELLS  (1  TO  19)  FITS.  JTABL  GIVES  THE 
HIGHEST  NUMBER  OF  THE  1  TO  19  SUB-SHELL  GROUPS 
INTO  WHICH  EACH  OF  THE  COMPACTED  GROUPS  FITS. 

THE  QUANTUM  SHELL  NUMBER  OF  EACH  OF  THE 
COMPACTED  GROUPS 

THE  99  ENERGIES  AT  WHICH  EACH  OF  THE  FIRST  99 
1  PERCENT  INTERVALS  OF  ENERGY  ARE  CENTERED.  AND 
THE  10  ENERGIES  AT  WHICH  THE  LAST  10  0.1  PERCENT 
INTERVALS  OF  ENERGY  ARE  CENTERED. 

THE  18  SCALES  AT  WHICH  LINEAR  PRINTER  PLOTS  ARE 
MADE  BY  THE  EDIT  SUB-ROUTINE. 

THE  15  DISTANCE  SCALES  (EACH  DIVIDED  INTO  100 
INTERVALS)  USED  FOR  LINEAR  PLOTTING  IN  EDIT. 

COMMON  BLOCK  /AB/ 

A  FLAG  SET  UP  IN  GENRAT  OR  IN  EQST  TO  INDICATE 
TO  FLOION  TO  CALCULATE  ZONE  IONIZATION  AND 
ENERGY  TRANSFER  IF  ICHCK  EQUALS  1.  ZONE 
IONIZATION  AND  ENERGY  DEPOSITION  IF  ICHCK 
EQUALS  ZERO. 

COMMON  BLOCK  /AC/ 
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NOEC(N) 

EDGEC(N , 20 ) 
EION(N.IOO) 
SCR£N0(N,20) 

NGRUP( 19) 
NSUM( 19) 

NSPDP( 14) 

NVARM(M) 

NVARE(N) 


NIONCN , 19) 


THE  HUMBER  OF  X-RAY  ABSORPTION  EDGES  CALCULATED 
BY  THE  CODE  TO  EXIST  FOR  ELEMENT  N  —  THERE  IS 
ONE  FOR  EACH  OF  THE  S,  P,  D,  AND  F  SUB-GROUPS 
IN  THE  ELEMENT. 

THE  ENERGY  CALCULATED  BY  THE  'CODE  AT  WHICH  THE 
ABSORPTION  EDGE  OCCURS. 

THE  ENERGY  OF  ELEMENT  N  IONS  WHEN  1  THROUGH  ALL 
ELECTRONS  ARE  REMOVED  FROM  THE  ATOM. 

THE  SCREENING  CONSTANTS  ASSOCIATED  WITH  THE 
NORMAL  SUB-SHELL  GROUPS  FOR  THE  NORMAL  ATOM 
OF  ELEMENT  N. 

THE  NUMBER  OF  ELECTRONS  IN  THE  SUB-SHELL  GROUPS. 
THE  NUMBER  OF  ELECTRONS  SUMMED  FROM  THE  FIRST 
SUB-SHELL 

THE  NUMBER  OF  ELECTRONS  IN  THE  COMPACTED 
SUB-SHELL  GROUPS 

AN  INPUT  VARIABLE  —  1  DENOTES  THAT  ALL  ELEMENTS 
IN  THIS  MATERIAL  HAVE  CONSTANT  -COLD-  ABSORPTION 
CROSS  SECTIONS  —  0  DENOTES  THAT  THE  ELEMENTS 
MAY  HAVE  VARIABLE  CROSS  SECTIONS. 

IF  THE  MATERIAL  IN  WHICH  THE  ELEMENT  OCCURS  HAS 
NVARM  -  0,  AND  NVARE  «  1.  THEN  CROSS  SECTION  IS 
CONSTANT  AND  COLD.  BUT  IF  NVARE  -  0,  THE  CROSS 
SECTION  IN  THIS  ELEMENT  IS  VARIABLE  AND 
DEPENDENT  ON  IONISATION  IN  THIS  ELEMENT. 

THE  NUMBER  OF  ELECTRONS  IN  THE  19  SUB- SHELL 
GROUPS  OF  THE  NORMAL  ATOM  OF  THIS  ELEMENT 


COMMON  BLOCK  /EQVP/ 

VARIABLES  USED  FOR  ELASTIC-VISCOPLASTIC  AND  GEOMETRIC  DISPERSIO 
MODELS . 

AMU2C6)  EFFECTIVE  SHEAR  MODULUS  FOR  THE  MAXWELL  GEOMETRIC 

DISPERSION  MODEL.  USED  WITH  THE  SECOND  STRESS  DEVIATOR 
WHICH  MODELS  THE  RATE  DEPENDENT  STRESS  CONTRIBUTION. 

INPUT  VARIABLE. 

CH(6)  CALCULATED  IN  GENRAT.  EQUAL  TO  THE  SOUND  SPEED  IN  THE 
MATERIAL  AT  SOLID  DENSITY. 

EQSTAC6)  PARAMETER  "A"  IN  THE  DISPERSIVE  MATERIAL  MODEL  FOR 
VISCOPLASTIC  E2HAVI0R.  INPUT  VALUE. 

G0KEC6)  CALCULATED  IN  GENRAT.  SHEAR  MODULUS  (AMU)  DIVIDED  BY 
EQSTC 

G0KE2C6)  CALCULATED  IN  GENRAT.  AMU2  DIVIDED  BY  EQSTC. 

GOVERK( 201 )  INITIALIZED  IN  GENRAT  AND  REDEFINED  IN  HYDRO. 
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PLASTIC  SHEAR  STRAIN. 

MFLAGC6)  FLAG  USED  IN  HYDRO  TO  ACTIVAE  THE  MAXWELL  GEOMETRIC 
DISPERSION  MODEL.  INPUT  VALUE. 

0MEGA(6)  PARAMETER  "V*  IN  THE  MAXWELL  GEOMETRIC  DISPERSION  MODEL. 
INPUT  VALUE. 

JB(6)  INDEX  OF  LEFT-HAND  BOUNDARY  OF  FIRST  ZONE  TREATED  AS 
DISPERSIVE  IN  EACH  DISPERSIVE  MATERIAL.  CALCULATED 
AND  USED  IN  HYDRO.  ALSO  USED  IN  EQST. 

PRELAX(6)  RELAXATION  STRESS  USED  IN  VISCOPLASTIC  MODEL.  INPUT 
VALUE. 

QU(201)  USED  IN  CALCULATION  OF  ARTIFICIAL  VISCOSITY  OF 
DISPERSIVE  MATERIALS. 

SD2( 201 )  SECOND  STRESS  DEVIATOR  USED  IN  MAXWELL  GEOMETRIC 
DISPERSION  MODEL.  CALCULATED  AND  USED  IN  HYDRO. 

SHEARRC6)  COEFFICIENT  USED  IN  THE  VARIABLE  SHEAR  MODULUS  MODEL 
ON  THE  UNLOADING  PATH.  INPUT  VALUE  (SIMILAR  TO 
BURGER'S  VECTOR) 

TRELAXC6)  CHARACTERISTIC  RELAXATION  TIME  FOR  VISCOPLASTIC  MODEL. 
INPUT  VALUE. 

TRELX2 ( 6 )  RELAXATION  TIME  FOR  THE  MAXWELL  GEOMETRIC  DISPERSION 
MODEL .  INPUT  VALUE . 

YY(201)  USED  IN  CALCULATION  OF  SD2  FOR  DISPERSIVE  MATERIALS. 

ZZ( 201 )  USED  IN  CALCULATION  OF  SD2  FOR  DISPERSIVE  MATERIALS. 

COMMON  BLOCK  /SPLLC/ 

VARIABLES  USED  TO  CALCULATE  FRACTURE 

EM  MELT  ENERGY  OF  THE  MATERIAL.  INPUT  QUANTITY. 

IS  FLAG  TO  INDICATE  IF  A  NEW  SPALL  HAS  OCCURED 

THIS  TIME  STEP. 

ISM  NUMBER  OF  SPALLS  OCCURRING  THIS  TIME  STEP. 

ISPALL  FLAG  TO  INDICATE  WHETHER  FRACTURE  IS  TAKING 

PLACE.  ZONES  ARE  BEING  RECOMBINED,  OR  NOTHING 
TAKING  PLACE  AT  ALL. 

ISPLLM  FLAG  TO  INDICATE  WHICH  FRACTURE  MODEL  IS  BEING 

USED  FOR  THE  MATERIAL.  INPUT  QUANTITY. 

-  1:  STRESS  MODEL  (BASED  ON  TENSILE  STRESS) 

-  2:  STRAIN  MODEL  (BASED  ON  BULK  TENSILE 
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C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

C 


C 

c 


STRAIN) 

-  3-10:  RESERVED  FOR  MODELS  YET  TO  BE  INCLUI 
JS  INDEX  OF  ZONE  BEING  SPALLED 

MS  INDEX  OF  SPALL  BOUNDARY 

SJ  CALCULATED  QUANTITY  TO  BE  COMPARED  WITH  TSPALL 

TO  DETERMINE  IF  SPALL  BAS  OC CURED 
SM  MOMENTUM  OF  THE  SPALLED  MATERIAL 

TSPALL  SPALL  STRENGTH  OF  A  ZONE  BASED  ON  PMIN  FOR  THE 

MATERIAL  IN  THE  SLID  STATE  AND  WHETHER  THE  ZONE 
IS  SOLID.  LIQUID.  GAS.  OR  PREVIOUSLY  SPALLED. 
PMIN  IS  THE  INPUT  QUANTITY  THAT  INDICATES  SPALL 
STRENGTH  OF  THE  SOLID  MATERIAL  AND  ITS  VALUE  IS 
BASED  ON  THE  SPALL  MODEL  FOR  THE  MATERIAL. 

XS  POSITION  OF  THE  RIGHT  HAND  BOUNDARY  OF  THE 

SPALLED  MATERIAL 

US  VELOCITY  OF  THE  RIGHT  HAND  BOUNDARY  OF  THE 

SPALLED  MATERIAL 


IMPORTANT  VARIABLES  LOCAL  TO  THIS  ROUTINE 

TR  THE  TIME  AT  WHICH  ENERGY  TRANSFER  RATES  SHOULD 

BE  RECALCULATED  BASED  ON  CHANGE 

OF  ENERGY  IN  MESH  (SEE  TRPRIM) 

TRPRIM  THE  TIME  AT  WHICH  THE  ENERGY  OF  A  ZONE  WILL  HAVE 

BEEN  ALTERED  BY  20  PERCENT  DUE  TO  ENERGY 
TRANSFER  ALONE 


BLANK 

AA 

AB 

AC 

EQED 

EQFL 

EQVP 

HYEQ 

PLOTCM 

RZCOM 

SPLLC  ' 

REAL  LGDEL 

CHARACTER  *10  ZZCTRL 
DIMENSION  ZZCTRL(40) 

DIMENSION  ZIP( 11366) 
EQUIVALENCE  ( ZIP( 1 ) . CS( 1 ) ) 

OPEN  STATEMENTS  FOR  F0RTRAN77 
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C 

OPEN  ( UNIT- 1 .ACCESS -'SEQUENTIAL ' .FORM-' UNFORMATTED ' , STATUS- ' SCR, 
1H-  ) 

OPEN  ( UNIT-2 , ACCESS- ' SEQUENTIAL ' , FORM- ' UNFORMATTED ' , STATUS- ' NEW ' ) 
OPEN  ( UNIT-3, STATUS-' NEW ' ) 

OPEN  ( UNIT- 5 .STATUS- 'OLD' ) 

OPEN  ( UNIT -6 . STATUS- ' NEW ' ) 

OPEN  ( UNIT-7,  STATUS-' NEW ' ) 

OPEN  (UNIT-8 .STATUS- 'NEW' ) 

OPEN  (UNIT-9,  STATUS- 'NEW' ) 

OPEN  (UNIT-10, ACCESS-' SEQUENTIAL' , FORM- ' UNFORMATTED ' , STATUS -' NEW ' ) 

1 

C 

C  ZEROES  COMMON 

C 

DO  10  J-l ,11366 
10  ZIP(J)-0. 

•IF  DEF.B64 

CALL  REMARK  ( ' SSWITCH  1  WILL  CAUSE  PROGRAM  TERMINATION ' ) 

•ENDIF 

CALL  GENRAT 
N-l 

TR-SSTOPM 
20  SDURM- S  STOPM 
JTRY-1 

30  CALL  HYDRO 
CALL  EQST 
C 

C  NOW  CHECK  FOR  SPALL 

C 

CALL  SPALL 
GO  TO  (40,30),  JTRY 
CALL  GOTOER 
C 

C  STOP  PARAMETERS 

C 

40  CONTINUE 

C  WRITE  (10)  TIME, (XFX(J) , J-l ,JFIN) 

•IF  DEF.B64 
C 

C  CHECK  TO  SEE  IF  SSWITCH  1  IS  SET.  IF  SO,  EXIT. 

C 

CALL  SSWTCH  (1,J) 

IF  (J.EQ.l)  GO  TO  90 

•ENDIF 

IF  ( TIME . LE . SSTOPM)  GO  TO  110 
IF  (SMAX)  50,100,50 
50  IF  (TIME-TS)  60,90,90 
60  IF  (N-JCYCS )  70,90,90 
70  IF  (X( JSMAX)-CKS)  80,90,90 
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80  CONTINUE 

*  IF  DEF.B64 

CALL  SSWTCH  (2,J) 

IF  (J.EQ.2)  GO  TO  110 
WRITE  (6,360)  N 

•ENDIF 

*  IF  DEF.B32 

GO  TO  110 

* ENDIF 

90  WTAPE-1. 

CALL  EDIT 

C  WRITE  (6,330)  (XFL( J) , J-l , JFIN) 

IF  (NJEDIT.NE.O)  CALL  PLOT 
STOP 

100  WRITE  (6,350)  N 
GO  TO  90 

EDIT  CONTROLS 

110  CONTINUE 

IF  (NJEDIT.NE.O)  WRITE  (8,330)  TIME .( S(JEDIT(J) ), J-l .NJEDIT) 

IF  (JPRIN.EQ.l)  GO  TO  130 
IF  ( MOD( N , NT APE ) )  140,120,140 
120  WTAPE-0 • 

130  CONTINUE 

IF  (JPRIN.EQ.l)  WTAPE-1. 

IF  DEF.B64 

ENCODE  (40 , 370 .ZZCTRL)  N.TIME.DTNH 

CABLING  OF  REMARK  PUTS  A  LINE  OF  OUTPUT  DATA  ON  THE  MACHINE  CONSOL 
SO  THAT  ONE  MAY  FOLLOW  THE  PROGRESS  OF  THE  CALCULATION  DURING 
RUNNING  OF  THE  PROBLEM  IF  DESIRED 

CALL  REMARK  (ZZCTRL) 

ENDIF 

CALL  EDIT 
GO  TO  160 

140  IF  ( MOD( N , NPRIN ) )  160,150,160 
150  WTAPE-0. 

GO  TO  130 

160  CONTINUE 

NOW  CHECK  FOR  REZONE 

IF  ( MOD( N , NREZON ) )  180,170,180 
170  IF  (TIME . GE . SSTOPM)  CALL  REZONE 
180  CONTINUE 

TIME  STEP  CALCULATION 
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NEW  TIME  STEP  (DTNH)  IS  THE  MINIMUM  OF  THE  STABLE  HYDRO  TIMS 
(SK2M),  1.1  TIMES  THE  OLD  TIME  STEP,  AND  THE  STABLE  TIME  FOR 
ENERGY  TRANSFER  FROM  ZONE  TO  ZONE. 


IF  DEF ,B64 

IF  (NTEDT. EQ.O)  SK2M-AMIN1 ( 0 . 9/SK2M , 1 . 1 *DTNH) 
IF  (NTEDT.EQ.l)  SK2M-AMIN1 ( 0 . 9/SK2M , 1 . 1 *DTNKP ) 

END  IF 

IF  DEF.B32 

IF  (NTEDT.EQ.O)  SK2M-DMIN1 (0 . 9/SK2M , 1 . 1 *DTNH) 
IF  (NTEDT.EQ.l)  SK2M-DMIN1 ( 0 . 9/SK2M , 1 . 1 *DTNKP ) 

END  IF 

IF  ( SSTOPM-TIME )  200.200,190 
190  CONTINUE 
IF  DEF.B64 

SK2M-AMIN1 (0.01*  SDURM , SK2M ) 

END  IF 

IF  DEF.B32 

SK2M-DMIN1 ( 0 . 01  * SDURM , SK2M) 

ENDIF 

200  DTN-DTNH 
DTNH-SK2M 

IF  (IFLOW.EQ.O)  GO  TO  220 
IF  ( DTNH-DTPRIM/2 . )  210,220,220 
210  I FLOW -0 

IF  ( TIME . LT . SSTOPM )  IFLOW-1 
IF  DEF.B64 

TR-TIME+AMIN1 (DTPRIM . 5 . *DTNH) 

ENDIF 

IF  DEF.B32 

TR-TIME+DMIN1 (DTPRIM . 5 . *  DTNH) 

ENDIF 


TR  IS  THE  TIME  AT  WHICH  THE  ENERGY  IN  SOME  ZONE  WILL  HAVE 
BEEN  ALTERED  BY  5  PERCENT  DUE  TO  ENERGY  TRANSFER  —  LIMIT 
THE  TIME  FOR  RECLACULAT ION  OF  ENERGY  TRANSFER  RATES  TO  THIS 
TIME  OR  LESS. 

TIME  EDIT 

220  IF  ( NTEDT )  260,260,230 
230  WTAPE-1 . 

CALL  EDIT 
IT-IT+1 

IF  (IT-26)  250,240,250 
240  IT-1 

TEDIT( 1 )-0 . 

250  NTEDT -0 

260  IF  (TEDIT(IT))  290,290,270 

270  IF  (TIME+DTNH-TEDIT( IT) )  290,280,280 
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280  DTNKP-DTNH 

DTNH-TEDIT( IT) -TIME 
NTEDT-1 

ADVANCE  PROBLEM  TIME 

290  TIME-TIME +DTNH 
DTN-DTN+DTNH 
DO  300  J-2.JFIN 
300  XFL( J)«XFL( J)+DTNH*XFX(J) 

IF  (IDIF.NE.O. AND. ICON. NE.O)  GO  TO  310 

I FLOW  EQUALS  ZERO  IS  A  CALL  FOR  RECALCULATION  OF  ENERGY 
TRANSFER  RATES. 

IF  (TIME.GT.TR)  I FLOW -1 

ADVANCE  CYCLE  NUMBER 

310  N-N+l 

IF  (N.GE.NDBG)  JPRIN-1 
IF  (DTNH)  320,320,20 
320  WRITE  (6,390)  N 
STOP 

330  FORMAT  (3X , 1P1 1E12 .4/ ) 

340  FORMAT  ( / / , 2X , 1 5HDTNH-0  AT  CYCLE, 15) 

350  FORMAT  ( / / , 2X . 15HSMAX-0  AT  CYCLE, 15) 

360  FORMAT  (31H  SENSE  SWITCH  2  IS  ON  AT  CYCLE  ,110) 

370  FORMAT  (6HCYCLE- , 15 , IX , 2HT- ,E1 1 . 3 , IX , 3HDT- , El 1 . 3) 

END 


onoo  o  o  ooono  oooo 


HYPUF  SOURCE  LISTING 


•DECK  AZONE 

SUBROUTINE  AZONE  (DX.NRZC) 

•IF  DEF.B32 

IMPLICIT  DOUBLEPRECIS ION (A-H.O-Z) 

•ENDIF 

C 

•CALL  BLANK 
•CALL  PLOTCM 

DIMENSION  A(20) ,  C(20),  D(20) 

THE  VALUE  OF  NRZC  INDICATES  WHETHER  THIS  IS  AN  INITIAL  ZONING 
ESTIMATE  OR  A  REVISED  ZONING  CALCULATION 

IF  (NRZC.LT.O)  GO  TO  50 

THIS  IS  OUR  INITIAL  ESTIMATE.  NRZC  IS  ZERO  AND  RZ  IS  THE 
THICKNESS  OF  EACH  MATERIAL  LAYER  IN  CM.  FIRST  WE  STORE  THE 
MATERIAL  LAYER  SIZES  AND  MASSES  FOR  LATER  USE. 

DX-0. 

DO  10  I-I.NMTRLS 
A(I)-0. 

D(I)-RHO(I)*RZ(I) 

C(I)-RZ(I) 

J-I-l 

IF  (I.GE.2)  C(I)-C(I)+C(J) 

10  CONTINUE 

IF  (NJEDIT.LE.O)  GO  TO  30 
DO  20  I-l.NJEDIT 
J-MTLN(I) 

K»J-1 

JEDITCD-I 
A(I)-DSTF(I)*C( J) 

IF  (J.EQ.l)  GO  TO  20 
A(I)-C(K)+DSTF(I)*(C(J)-C(K)) 

20  CONTINUE 

WRITE  (6.170)  ( JEDIT(I) ,A(I) . I-l.NJEDIT) 

30  CONTINUE 

D  IS  NOW  THE  TOTAL  MASS  IN  EACH  MATERIAL  LAYER  AND  C(NMTRLS) 
IS  THE  TOTAL  THICKNESS  OF  THE  PROBLEM. 

N-150/NMTRLS 
M-N-l 
DX-1 .E-5 
DO  40  I-l.NMTRLS 
IF  ( D( I ) . LE . 0 . )  STOP  2 
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NRZC-NRZC+N 
JBND( I )-NRZC+l 
J»2*I 
K-J-l 

NZ(K)-JBNDCI) 

NZ(J)«JBND(I)+1 

Dl-DX 

D2-DCI) 

CALL  FINDRZ  (D1 ,D2 ,N ,RZ1 ) 

R2(K)*RZI 

D2«DX*RZ1**M 

L-I+l 

IF  (I. EQ. NMTRLS)  L-I 

RZ( J)-DX*RHO(L)/(D2*RHO(I)) 

IF  (JPRIN.EQ.l)  WRITE  (6,180)  I ,K,NZ(K) ,RZ(K) , V(X) . ZM(K) 

C 

40  CONTINUE 
C 

NRZC-0 

JFIN- JBND( NMTRLS ) 

WE  HAVE  COMPLETED  OUR  FIRST  GUESS  AT  THE  ZONING-  WE  NOW  REDEFINE 
DX  TO  BE  THE  FIRST  ZONE  SIZE  DIVIDED  BY  ZONE  RATIO  RATHER  THAN 
ZONE  MASS. 

DX-DX/RHO( 1 ) /RZ( 1 ) 

RETURN 
50  CONTINUE 

THIS  IS  OUR  SECOND  AND  FINAL  CALCULATION  OF  THE  ZONING.  DX  HAS 
BEEN  REDEFINED  AS  THE  DISTANCE  THE  STRESS  WAVE  WILL  PROPOGATE 
DURING  THE  SHINE  TIME 


N-l 

Dl-O. 

D2-0. 

DO  70  1-1 .NMTRLS 
D2-D2+DC I ) 

IF  (DX.LT.C(I))  GO  TO  60 
D1-D1+DCI) 

GO  TO  70 
60  CONTINUE 

IF  (N.EQ.l)  D1-D1+D(I)+(DX-C(I))*RH0(I) 

N-N+l 

70  CONTINUE 

WE  HAVE  TEMPORARILY  DEFINED  D1  AS  THE  MASS  THROUGH  WHICH  WE 
EXPECT  THE  SHOCX  TO  PROPOGATE  DURING  SHINE  TIME.  WE  HAVE  ALSO 
TEMPORARILY  DEFINED  D2  AS  THE  TOTAL  MASS  OF  THE  PROBLEM.  WE 
NOW  WISH  TO  REZONE  THE  PROBLEM  WITH  50  EQUAL  MASS  ZONES  FOR  THE 
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REGION  THROUGH  WHICH  THE  SHOCK  WILL  PROROGATE  DURING  SHINE  TIME 
AND  100  ZONES  FOR  THE  $EST  OF  THE  PROBLEM.  HOWEVER,  IF  THE 
SHOCK  IS  EXPECTED  TO  PROPOGATE  TOO  FAR,  THEN  WE  WILL  SIMPLY 
LEAVE  THE  ZONING  AS  IT  WAS  IN  OUR  FIRST  GUESS. 

IF  ( NMTRLS . EQ . 1 )  C(2)-C(l) 

V(l)-X(2) 

K-l 

IF  (DX.GE.CC2))  GO  TO  130 

D3-D2-D1 

D4«.02*D1 

D5- . 01 *D3 

NOW  WE  PLAN  TO  DEFINE  NZ  AS  THE  HIGHEST  ZONE  NUMBER  IN  A  REGION, 
RZ  AS  THE  ZONE  SIZE  RATIO  FOR  THAT  REGION,  AND  V  AS  THE 
CORRESPONDING  ZONE  THICKNESSES  IN  THAT  REGION. 


J-l 

K-0 

DO  120  1-1, NMTRLS 
IM1-I-1 

IF  (DX.GT.C(I))  GO  TO  110 

DX  IS  .LE.  C(I).  NEED  TO  SEE  IF  I  .EQ.  1 

IF  (I.GE.2)  GO  TO  90 

NOW  WE  KNOW  THAT  DX  .LE.  C( 1 ) 

K-K+l 
NZ(K)-51 
V(K)-.02*DX 
ZM(K)-D4 
RZ(K)«1 . 

IF  ( JPRIN.EQ. 1 )  WRITE  (6,180)  I ,K,NZ(K) ,RZ(K) , V(K) , ZM(K) 
IF  (DX.EQ.C(I))  GO  TO  80 

HERE  DX  .LT.  C(l)  .AND.  DX  .NE.  C(l) 


N-K 

K-K+l 

ZM(K)-(C(I) -DX) *RHO( I )+ZM(N) 

NRZC«ZM(K)/D5 

NRZC-MAXO ( NRZC , 20 ) 

NZ ( K ) -NZ ( N ) +NRZC 

D1-D4 

D2-ZM(K) 

M-NRZC+1 

CALL  FINDRZ  ( D1 , D2 , M , RZ1 ) 
RZ(K)-RZ1 
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M-NRZC 

D2-D1*RZ1**M 

ZM(K)-D2 

V(K)-D2/RH0(I) 

IF  (JPRIN.EQ.l)  WRITE  (6,180)  I ,K,NZ(K) ,RZ(K) , V(K) ,ZM(K) 
JBND(I)-NZ(K) 

GO  TO  120 
80  CONTINUE 
C 

C  HERE  DX  .EQ.  C(l) 

C 

JBND(I)«NZ(K) 

GO  TO  120 
90  CONTINUE 
C 

C  NOW  WE  HAVE  C(l)  .LT.  DX  .LT.  C(2) 

C 

N-K 

K-K+l 

V(K)«DX-C(IM1) 

IF  (V(K).LE.O.)  GO  TO  100 
C 

C  NOW  WE  ARE  IN  THE  REGION  BETWEEN  C(l)  AND  DX. 

C 

ZM(K)-V(K) *RHO( I ) 

NRZC-ZM(K)/D4 

V(X)-V(X)/NRZC 

ZM(K)-V(K)«RHO(I) 

Dl-ZM(K) 

RZ(K)-V(K)/V(N) 

NZ(K)-1+NZ(N) 

IF  (JPRIN.EQ.l)  WRITE  (6,180)  I ,K,NZ(K) ,RZ(K) , V(K) , ZM(K) 

N-K 

K-K+l 

RZ(K)-1. 

NZ ( K ) -NZ( N ) +NRZC- 1 

ZM(K)-D1 

V(K)-D1/RH0(I) 

IF  (JPRIN.EQ.l)  WRITE  (6,180)  I ,K,NZ(K) ,RZ(K) , V(K) , ZM(K) 
C 

C  NOW  WE  ARE  IN  THE  REGION  BETWEEN  DX  AND  C(2) 

C 

N-K 

K-K+l 

V(K)-C( I )-DX 
ZM(K)-V(K) *RHO( I )+Dl 
NRZC-ZM(K) /D5 
NRZC-HAXO ( NRZC , 20 ) 

D2-ZM(K) 

M-NRZC+1 
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CALL  FINDRZ  (D1 ,D2 ,M,RZ1 ) 

M-NRZC 

RZ(K)-RZ1 

D2-D1*RZ1**M 

NZ(K)-NZ(N)+NRZC 

ZM(K)«D2 

V(K)-D2/RH0(I) 

JBND(I)-NZ(K) 

IF  ( JPRIN . EQ . 1 )  WRITE  (6,180)  I ,K,NZ(K) ,RZ(K) . V(K) ,ZM(K) 

GO  TO  120 
100  CONTINUE 
C 

C  NOW  WE  ARE  IN  THE  SITUATION  WHERE  DX  .LT.  C(IM1).  THEREFORE 
C  WE  SIMPLY  ZONE  FOR  CONSTANT  ZONE  MASS  RATIO. 

C 

Dl-ZM(N) 

D2«D(I)+D1 
NRZC-D2/D5 
NRZC-MAXO ( NRZC , 20 ) 

NZ(K)-NZ(N)+1 

RZ(K)-RH0(IM1)/RH0(I) 

V(K)«D1/RH0(I) 

IF  (JPRIN. EQ.l)  WRITE  (6.180)  I  ,K,NZ(K) , RZ(K) , V(K) , ZM(K) 

N-K 

K-K+l 

M-NRZC 

CALL  FINDRZ  (Dl ,D2 ,M ,RZ1 ) 

M-NRZC- 1 

D2-D1 *RZ1 *  *M 

NZ(K)-NZ(N)+M-1 

RZ(K)-RZ1 

RZ( N)-RZ(N) *RZ1 

V ( N ) -RZ1 * V ( N ) 

ZM(N)«RZ1*ZM(N) 

IF  (JPRIN. EQ.l)  WRITE  (6,180)  I ,N ,NZ(N) ,RZ(N) , V(N) , ZM(N) 

ZM(K)-D2 

V(K)-D2/RH0(I) 

IF  (JPRIN. EQ.l)  WRITE  (6,180)  I ,K, NZ(K) ,RZ(K) , V(K) ,ZM(K) 
JBND( I)-NZ(X) 

GO  TO  120 
110  CONTINUE 
C 

C  WE  ARE  IN  THE  FIRST  MATERIAL  REGION  AND  C(l)  .LT.  DX. 

C 

K-K+l 

ZM(K)-D(I) 

NRZC»ZM(K)/D4 
NZ(K)-NRZC+1 
RZ(K)-1 . 

ZM(K)-ZM(K) /NRZC 
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V(K)«ZM(K)/RHO(I) 

IF  (JPRIN.EQ.l)  WRITE  (6.180)  I ,K.NZ(K) ,RZ(K) ,V(K) ,ZM(K) 
JBND(I)-NZ(K) 

120  CONTINUE 
C 

C  WE  HAVE  NOW  FINISHED  CALCULATING  NZ  AND  RZ.  ALL  WE  NEED  TO  DO  IS 
C  SET  DX  -  V(l)  AND  THEN  ZERO  OUT  THE  X.  V.  AND  U  ARRAYS.  FINALLY. 

C  WE  RESET  NRZC  -  -  X  AS  A  FLAG  TO  SHOW  WE  HAVE  FINISHED  OUR 

C  CALCULATION  OF  ZONE  SIZES. 

C 

X(2)-V(l) 

130  CONTINUE 
DX-XC2) 

D1«DX/RZ(1) 

JFIN-NZ(K) 

J-l 

K-l 

X(l)-0. 

DO  150  I-2.JFIN 

IM1-I-1 

V(I)-0. 

ZH(I)-0. 

IF  (I.GT.NZ(K))  K-K+l 
D1-D1*RZ(K) 

X( I )«X( IM1 )+Dl 
IF  (J.GT.NJEDIT)  GO  TO  ISO 
140  CONTINUE 

IF  (X(I) .LT.A(J) )  GO  TO  150 

JEDIT(J)-I 

J-J+l 

IF  (J.LE.NJEDIT)  GO  TO  140 
150  CONTINUE 

IF  (NJEDIT.EQ.O)  GO  TO  160 

WRITE  (6,170)  (JEDIT(I) ,X( JEDIT(I)) ,I»1 .NJEDIT) 

160  CONTINUE 
V(1)«0. 

ZM(l)-0. 

NRZC— K 
RETURN 
C 

C**  THIS  PROGRAM  VALID  ON  FTN4  AND  FTN5  ** 

C 

170  FORMAT  (20H0  JEDIT ,  X(JEDIT)  - , 5( 15 . 1PE12 .4) / ) 

180  FORMAT  (1H0.3HI  «,I3,5X,3HX  -.I3.5X.4HNZ  -.I4.5X.4HRZ  -.1PE15.7.5X 
1  , 3HV  - , 1PE15 . 7 , 5X , 4HZM  -.1PE15.7/) 

END 
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•DECK  BLKDAT 

BLOCK  DATA 
•IF  DEF.B32 

IMPLICIT  DOUBLEPRECIS ION (A-H.O-Z) 

•ENDIF 

C 

•CALL  AA 
•CALL  AB 
•CALL  AC 
•CALL  EQED 
•CALL  EQFL 
•CALL  EQVP 
•CALL  INDX 
•CALL  SPLLC 

DATA  ITBL(l.l),  ITBL(1,2),  ITBL(1,3),  ITBLCl.4),  ITBL(1,5),  ITBL( 1 
1  .6)  /l, 0.0, 0,0,0/ 

DATA  ITBL(2 , 1 ) ,  ITBL(2,2),  ITBL(2.3),  ITBLC2.4),  ITBL(2,5).  ITBL(2 
1  ,6)  /2, 0.0. 0.0.0/ 

DATA  ITBL(3 , 1 ) ,  ITBL(3,2),  ITBL(3,3),  ITBL(3,4),  ITBL(3,5).  ITSLC3 
1  ,6)  /2. 1.0, 0,0.0/ 

DATA  ITBL(4. 1) ,  ITBL(4,2),  ITBL(4,3),  ITBL(4,4),  ITBL(4,5),  ITBL(4 

1  ,6)  /2, 2. 0,0, 0.0/ 

DATA  ITBL( 5,1),  ITBL(5,2).  ITBL(5,3),  ITBL(5,4),  ITBLC5.5),  ITBL(5 

1  ,6)  /2, 2. 1,0. 0.0/ 

DATA  ITBL(6 , 1 ) ,  ITBL(6.2),  ITBL(6,3),  ITBLC6.4).  ITBL(6,5),  ITBL(6 
1  .6)  /2, 2. 2. 0,0,0/ 

DATA  ITBL(7 ,  1 )  ,  ITBL(7.2),  ITBL(7,3),  ITBL(7,4).  ITBL(7,5).  ITBL(7 

1  ,6)  /2. 2. 3, 0,0.0/ 

DATA  ITBL( 8.1),  ITBL(8,2),  ITBL(B,3),  ITBLC8.4),  ITBL(8.5),  ITBL(8 

1  ,6)  /2. 2, 4. 0,0,0/ 

DATA  ITBL(9,1),  ITBL(9,2),  ITBL(9,3).  ITBLC9.4),  ITBL(9,5).  ITBL(9 

1  ,6)  /2, 2. 5. 0.0,0/ 

DATA  ITBL(lO.l),  ITBL(10,2),  ITBL(10,3),  ITBLC10.4),  ITBLC10.5), 

1  ITBL( 10,6)  /2, 2,6,0, 0,0/ 

DATA  ILTBL1  /2,2,6/ 

C 

DATA  ITBL(ll.l),  ITBL(11,2),  ITBL(11,3),  ITBL(11,4),  ITBL(U,5), 

1  ITBL( 11,6)  /I ,0,0, 0,0,0/ 

DATA  ITBL( 12,1),  ITBL(12,2),  ITBL(12,3),  ITBL(12,4),  ITBL(12,5). 

1  ITBL( 12,6)  /2, 0,0, 0,0,0/ 

DATA  ITBL( 13,1),  ITBL(13.2),  ITBL(13,3),  ITBL(13,4).  ITBL(13,5), 

1  ITBLC 13,6)  /2, 1,0, 0,0.0/ 

DATA  ITBL( 14,1),  ITBL(14,2),  ITBL(14,3),  ITBL(14,4),  ITBLC14.5). 

1  ITBLC 14,6)  /2, 2, 0,0, 0,0/ 

DATA  ITBLC 15,1),  ITBLC 15, 2),  ITBLC 15, 3).  ITBLC 15,4),  ITBLC 15. 5). 

1  ITBLC 15,6)  /2, 3, 0,0, 0,0/ 

DATA  ITBLC 16,1),  ITBLC16.2).  ITBLC16.3),  ITBLC16.4),  ITBLC16.5), 

1  ITBLC 16,6)  /2, 4, 0,0, 0,0/ 

DATA  ITBLC 17,1),  ITBLC17.2),  ITBLC17.3),  ITBL(17,4),  ITBLC17.5), 
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C 


1  ITBL( 17 ,6)  /2. 5. 0.0. 0,0/ 
DATA  IT5L( 18,1),  ITBLC 18. 2), 
1  ITBLC 18,6)  /2, 6. 0,0, 0,0/ 
DATA  ITBL( 19,1),  ITBLC19.2), 
1  ITBL( 19,6)  /2, 6, 0,1, 0,0/ 
DATA  ITBL( 20.1),  ITBLC20.2), 
1  ITBL( 20 ,6)  /2, 6, 0.2, 0,0/ 
DATA  ITSL( 21,1),  ITBL(21,2), 
1  ITBL( 21,6)  /2, 6, 1,2, 0.0/ 
DATA  ITBL(22 , 1 ) ,  ITBL(22,2), 
1  ITBL(22 ,6)  /2, 6, 2, 2. 0,0/ 
DATA  ITBL(23,1),  ITBL(23,2), 
1  ITBLC23.6)  /2, 6, 3, 2, 0,0/ 
DATA  IT6L(24 , 1 ) ,  ITBL(24.2), 
1  ITBL(24 ,6)  /2. 6, 5, 1,0,0/ 
DATA  ITBLC25.1),  ITBL(25,2), 
1  ITBLC25.6)  /2, 6. 5, 2, 0,0/ 
DATA  ITBLC26 , 1 ) ,  ITBLC 26, 2), 
1  ITBL(26,6)  /2. 6, 6, 2. 0.0/ 
DATA  ITBLC 27 , 1 ) ,  ITBL(27,2), 
1  ITBLC27.6)  /2 ,6 , 7 , 2 , 0 , 0/ 
DATA  ITBLC28.1),  ITBL(28.2), 
1  ITBLC28.6)  /2, 6. 8, 2. 0,0/ 
DATA  ILTBL2  /2.6.10/ 


ITBL( 18,3) . 
ITBL( 19,3) , 
ITBL( 20,3) , 
ITBLC21 ,3) , 
ITBL( 22,3) , 
ITBL( 23,3) , 
ITBL(24 ,3) , 
ITBLC25.3) , 
ITBLC26.3) , 
ITBLC27.3) , 
ITBLC28 ,3) , 


ITBLC18.4) , 
ITBL( 19,4), 
ITBL( 20,4) , 
ITBLC21 .4) , 
ITBL(22 ,4) , 
ITBL(23 ,4) , 
ITBL( 24,4) , 
ITBLC25.4) , 
ITBL(26 ,4) , 
ITBLC27.4), 
ITBLC28 ,4) , 


DATA  ITBLC29.1),  ITBL(29,2), 
1  ITBL(29,6)  /l. 0.0, 0,0,0/ 
DATA  ITBL( 30,1),  ITBL(30,2), 
1  ITBL( 30,6)  /2, 0.0, 0,0,0/ 
DATA  ITBLC31.1),  ITBLC31.2), 
1  ITBL( 31 ,6)  /2, 1.0, 0,0,0/ 
DATA  ITBLC32.1),  ITBL(32,2). 
1  ITBL( 32,6)  /2, 2, 0,0, 0,0/ 
DATA  ITBLC33 , 1 ) ,  ITBL(33,2), 
1  ITBL( 33 ,6)  /2, 3, 0,0, 0,0/ 
DATA  ITBL( 34,1),  ITBL(34,2), 
1  ITBLC 34,6)  /2. 4, 0,0, 0,0/ 
DATA  ITBLC35.1),  ITBL(35,2), 
1  ITBLC 35. 6)  /2, 5. 0,0, 0,0/ 
DATA  ITBLC 36 , 1 ) .  ITBLC 36, 2), 
1  ITBLC 36,6)  /2, 6, 0,0, 0.0/ 
DATA  ITBLC 37,1),  ITBLC 37. 2), 
1  ITBLC  37,6)  /2, 6. 0,0, 1,0/ 
DATA  ITBLC 38,1),  ITBLC 38. 2), 
1  ITBLC 38,6)  /2, 6, 0,0, 2,0/ 
DATA  ITBLC  39,1),  ITBLC 39, 2), 
1  ITBLC 39, 6)  /2.6.1 ,0,2,0/ 
DATA  ITBLC 40.1),  ITBLC 40, 2), 
1  ITBLC 40,6)  /2, 6, 2, 0,2,0/ 
DATA  ITBLC 41,1),  ITBLC 41,2), 


ITBLC 29 , 3) , 
ITBLC 30, 3) , 
ITBLC 31 ,3) , 
ITBLC 32, 3) , 
ITBLC 33, 3) , 
ITBLC 34, 3) , 
ITBLC 35, 3) , 
ITBLC 36, 3) , 
ITBLC 37, 3) , 
ITBLC 38, 3)  , 
ITBLC 39, 3) , 
ITBLC 40, 3) , 
ITBLC41 ,3) , 


ITBLC 29, 4) , 
ITBLC 30, 4), 
ITBLC  31,4), 
ITBLC  32,4), 
ITBLC 33 ,4) , 
ITBLC 34, 4) , 
ITBLC 35. 4) . 
ITBLC 36,4), 
ITBLC 37,4), 
ITBLC 38,4), 
ITBLC 39,4), 
ITBLC 40, 4) . 
ITBLC 41 ,4) , 


ITBLC 18,5), 
ITBLC 19,5 )  , 
ITBLC  20,5), 
ITBLC 21 ,5)  , 
ITBLC 22, 5) , 
ITBLC  23,5), 
ITBLC  24,5), 
ITBLC 25, 5) , 
ITBLC 26, 5) , 
ITBLC 27, 5) , 
ITBLC 28, 5) . 

ITBLC 29, 5) , 
ITBLC 30, 5), 
ITBLC 31 ,5) , 
ITBLC 32, 5) , 
ITBLC 33, 5) , 
ITBLC 34, 5) , 
ITBLC 35, 5) , 
ITBLC  36,5). 
ITBLC  37,5). 
ITBLC  38,5). 
ITBLC 39. 5) , 
ITBLC 40, 5) . 
ITBLC 41 ,5) , 
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C 


1  ITBLC41.6)  /2. 6,4, 0.1,0/ 
DATA  ITBLC42.1),  ITSL(42.2). 
1  ITEL(42 ,6)  /2, 6, 5, 0.1,0/ 
DATA  ITBL(43 , 1 ) ,  ITBL(43.2), 
1  ITBL(43 ,6)  /2 ,6 ,6 , 0 , 1 , 0/ 
DATA  ITBL(44,1),  ITBL(44,2), 
I  ITBL(44 ,6)  /2, 6, 7, 0.1,0/ 
DATA  ITBL(45 , 1 ) .  ITBL(45,2), 
1  ITBL(45 ,6)  /2, 6. 8. 0,1.0/ 
DATA  ITBLC46.1).  ITBLC46.2), 
1  ITBL(46 ,6)  /2, 6. 10.0.0.0/ 
DATA  ILTBL3  /2.6.10/ 


ITBL(42.3) . 
ITBL( 43,3) , 
ITBL(44 , 3) , 
ITBL(45 , 3)  . 
ITBLC46.3) , 


ITBL(42 ,4) . 
ITBL(43 ,4) , 
ITBL(44 , 4) . 
ITBL(45 ,4) , 
ITBL(46 ,4) , 


DATA  ITBLC 47 , 1 ) ,  ITBLC47.2). 
1  ITBLC47.6)  /0, 1,0. 0,0,0/ 
DATA  ITBL(48,1).  ITBL(48,2), 
1  ITBL(48,6)  /0, 2, 0,0, 0,0/ 
DATA  ITBL(49 , 1 ) ,  ITBL(49,2), 
1  ITBL(49.6)  /O, 2, 1,0, 0,0/ 
DATA  ITBLC 50,1),  ITBL(50,2), 
1  ITBL( 50 ,6)  /O, 2. 2, 0,0,0/ 
DATA  ITBLC 51 , 1 ) ,  ITBLC 51, 2). 
1  ITBLC 51 ,6)  /O, 2, 3, 0,0,0/ 
DATA  ITBLC 52,1),  ITBLC 52. 2), 
1  ITBLC 52, 6)  /O. 2, 4, 0,0,0/ 
DATA  ITBLC 53,1),  ITBLC 53, 2). 
1  ITBLC 53, 6)  /O. 2, 5. 0,0.0/ 
DATA  ITBLC 54,1),  ITBLC 54, 2), 
1  ITBLC 54,6)  /0, 2, 6, 0,0,0/ 
DATA  ITBLC 55,1),  ITBLC 55, 2), 
1  ITBLC 55,6)  /0, 2, 6, 0,0,1/ 
DATA  ITBLC 56,1),  ITBLC56.2), 
1  ITBLC 56,6)  /0, 2, 6, 0,0, 2/ 
DATA  ITBLC 57,1),  ITBLC57.2), 
1  ITBLC 57,6)  /0,2,6,1 ,0,2/ 
DATA  ITBLC 58,1),  ITBLC58.2), 
1  ITBLC 58 ,6)  /2, 2, 6, 0,0, 2/ 
DATA  ITBLC 59,1),  ITBLC 59, 2), 
1  ITBLC 59,6)  /3, 2, 6, 0.0, 2/ 
DATA  ITBLC 60 , 1 ' ,  ITBLC 60, 2), 
1  ITBLC 60 ,6)  /4, 2, 6, 0,0, 2/ 
DATA  ITBLC61.1),  ITBL(61,2), 
1  ITBLC61.6)  /5, 2, 6,0, 0.2/ 
DATA  ITBLC 62 , 1 ) ,  ITBLC 62, 2), 
1  ITBLC 62 ,6)  /6, 2. 6, 0,0, 2/ 
DATA  ITBLC 63 , 1 ) ,  ITBLC 63, 2), 
1  ITBLC 63 ,6)  /7, 2, 6, 0,0, 2/ 
DATA  ITBLC 64 , 1 ) ,  ITBLC 64, 2). 
1  ITBLC 64,6)  /7, 2, 6, 1.0. 2/ 
DATA  ITBLC65 , 1 ) ,  ITBLC 65, 2), 


ITBLC47.3) , 
ITBLC48.3) , 
ITBLC 49 , 3) , 
ITBLC 50, 3) . 
ITBLC51 ,3) , 
ITBLC 52, 3). 
ITBLC 53, 3), 
ITBLC 54, 3) , 
ITBLC 55 , 3) , 
ITBLC 56, 3) , 
ITBLC 57, 3), 
ITBLC 58, 3) , 
ITBLC 59, 3) , 
ITBLC 60, 3) , 
ITBLC61 ,3) , 
ITBLC 62, 3) , 
ITBLC 63, 3) , 
ITBLC 64, 3)  , 
ITBLC 65, 3) , 


ITBLC 47, 4) , 
ITBLC48.4) . 
ITBLC 49, 4) , 
ITBLC 50, 4) , 
ITBLC 51 ,4) , 
ITBLC 52, 4) , 
ITBLC 53, 4), 
ITBLC 54, 4), 
ITBLC 55. 4) , 
ITBLC 56. 4) , 
ITBLC 57, 4) , 
ITBLC 58, 4) . 
ITBLC 59. 4) , 
ITBLC 60 ,4) , 
ITBLC 61 ,4) , 
ITBLC 62, 4) . 
ITBLC 63, 4) . 
ITBLC 64, 4) . 
ITBLC65.4) . 


ITBLC 42,5) , 
ITBLC 43 . 5 ) . 
ITBLC44.5) , 
ITBLC 45 ,5) , 
ITBLC 46 , 5 ) , 

ITBLC 47, 5) , 
ITBLC 48, 5) , 
ITBLC 49, 5), 
ITBLC  50,5), 
ITBLC 51 ,5) , 
ITBLC 52. 5) , 
ITBLC 53, 5) , 
ITBLC 54, 5), 
ITBLC  55,5), 
ITBLC  56,5), 
ITBLC 57, 5) , 
ITBLC  58,5), 
ITBLC 59, 5) , 
ITBLC60.5)  , 
ITBLC61.5) , 
ITBLC 62 , 5 )  , 
ITBLC63.5)  , 
ITBLC 64 , 5 )  , 
ITBLC65.5)  . 
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C 


C 


1  ITBLC65 .6)  /9. 2, 6, 0.0, 2/ 
DATA  ITBL(66 , 1 ) ,  ITBL(66.2), 
I  ITBL(66,6)  /10, 2. 6. 0,0. 2/ 
DATA  ITBL(67 , 1 ) ,  ITBLC67.2), 
1  ITBL(67 ,6)  /U, 2, 6. 0,0, 2/ 
DATA  ITBL(€8 , I ) ,  ITBL(68.2), 
1  ITBL(68 ,6)  /12, 2, 6, 0,0. 2/ 
DATA  ITBL(69 , 1 ) ,  ITBL(69.2), 
1  ITBL(69 ,6)  /13, 2, 6. 0,0, 2/ 
DATA  ILTBL4C1)  /14/ 


ITBLC 66, 3) 
ITBL(67,3) 
ITBL(68 , 3) 
ITBL(69 , 3) 


ITBL(66 ,4) , 
ITBLC 67 ,4)  , 
ITBL(68 ,4) , 
ITBLC69.4) , 


DATA  ITBL(70 , 1 ) ,  ITBL(70,2), 
1  ITBL( 70,6)  /2, 6. 0,0, 2,0/ 
DATA  ITBL(71 , 1 ) ,  ITBL(7I,2), 
1  ITBL( 71 ,6)  /2,6,1 .0,2,0/ 
DATA  ITBLC 72,1),  ITBLC72.2), 
1  ITBL( 72,6)  /2. 6. 2. 0,2,0/ 
DATA  ITBLC 73 , 1 ) ,  ITBLC 73, 2), 
1  ITBLC 73,6)  /2, 6, 3, 0,2,0/ 
DATA  ITBLC 74.1),  ITBLC 74. 2), 
1  ITBLC 74,6)  /2, 6, 4, 0,2,0/ 
DATA  ITBLC 75 , 1 ) ,  ITBLC75.2), 
1  ITBLC 75 ,6)  /2. 6, 5, 0,2,0/ 
DATA  ITBLC 76 , 1 ) ,  ITBLC76.2), 
1  ITBLC 76 ,6)  /2. 6, 6. 0,2,0/ 
DATA  ITBLC 77 , 1 ) ,  ITBLC77.2), 
1  ITBLC 77,6)  /2. 6, 7, 0,2,0/ 
DATA  ITBLC 78 , 1 ) ,  ITBLC 78, 2). 
1  ITBLC 78 ,6)  /2,6,9,0, 1 ,0/ 
DATA  ILTBL5  /2.6.10/ 


ITBLC 70, 3) , 
ITBLC71 ,3) , 
ITBLC72.3) , 
ITBLC 73 , 3) , 
ITBLC 74 ,3) , 
ITBLC 75, 3), 
ITBLC 76, 3) , 
ITBLC 77 ,3) , 
ITBLC 78 , 3) , 


ITBLC70.4), 
ITBLC 71, 4) , 
ITBLC 72, 4) , 
ITBLC 73, 4) . 
ITBLC 74, 4) , 
ITBLC75V4)  , 
ITBLC 7674) , 
ITBLC 77, 4), 
ITBLC 78 ,4) , 


DATA  ITBLC 79 , 1 ) ,  ITBLC79.2), 
1  ITBLC 79,6)  /O, 1,0, 0,0,0/ 
DATA  ITBLC 80,1),  ITBLC 80, 2), 
1  ITBLC  80,6)  /0, 2. 0,0, 0,0/ 
DATA  ITBLC 81.1),  ITBLC 81, 2), 
1  ITBLC  81,6)  /0. 2, 1,0, 0.0/ 
DATA  ITBLC 82,1),  ITBLC 82, 2), 
1  ITBLC 82,6)  /0, 2, 2, 0.0,0/ 
DATA  ITBLC 83,1).  ITBLC 83,2), 
1  ITBLC 83,6)  /0, 2, 3, 0,0,0/ 
DATA  ITBLC  84,1),  ITBLC  84,2), 
1  ITBLC 84,6)  /O, 2, 4, 0,0,0/ 
DATA  ITBLC 85,1),  ITBLC 85, 2), 
1  ITBLC  85,6)  /O, 2, 5, 0,0,0/ 
DATA  ITBLC 86.1),  ITBLC 86, 2), 
1  ITBLC 86,6)  /O, 2, 6, 0,0,0/ 
DATA  ITBLC  87,1),  ITBLC 87, 2), 
1  ITBLC  87,6)  /O, 2, 6, 0,0,1/ 
DATA  ITBLC 88,1),  ITBLC 88, 2), 


ITBLC 79, 3) , 
ITBLC 80 ,3) , 
ITBLC 81 , 3) , 
ITBLC 82 ,3) , 
ITBLC 83, 3) . 
ITBLC 84, 3) . 
ITBLC 85, 3) , 
ITBLC 86, 3) . 
ITBLC 87, 3)  , 
ITBLC 88, 3) , 


ITBLC 79, 4) , 
ITBLC 80, 4), 
ITBLC 81 ,4) . 
ITBLC 82, 4). 
ITBLC 83, 4) , 
ITBLC 84,4) , 
ITBLC 85, 4) , 
ITBLC 86, 4) . 
ITBLC 87. 4) . 
ITBLC  88,4), 


ITBLC 66 , 5 ) , 
ITBLC 67 , 5 ) . 
ITBLC 68 . 5 ) , 
ITBLC 69 , 5) , 

ITBLC 70, 5) , 
ITBLC71.5) , 
ITBLC 72 , 5 ) , 
ITBLC 73 , 5) , 
ITBLC 74, 5) , 
ITBLC 75, 5) , 
ITBLC 76. 5) , 
ITBLC  77. 5) , 
ITBLC 78 ,5) , 

ITBLC 79, 5) , 
ITBLC 80, 5) . 
ITBLC 81 , 5) , 
ITBLC 82, 5) , 
ITBLC 83, 5) . 
ITBLC 84, 5) , 
ITBLC 85. 5) , 
ITBLC  86,5), 
ITBLC 87, 5) , 
ITBLC 88, 5) . 
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1  ITBL( 88.6)  /0, 2, 6, 0,0, 2/ 

DATA  ITBL( 89,1),  ITBL(89,2),  ITBL(89,3),  ITBL(89,4),  ITBL(89,5), 

1  ITBL( 89,6)  /O. 2, 6. 1,0, 2/ 

DATA  ITBL(90, 1 ) ,  ITBL(90,2),  ITBL(90,3),  ITBL(90,4),  ITBL(90,5), 

1  ITBLC90.6)  /O, 2, 6, 2, 0,2/ 

DATA  ITBL( 91,1),  ITBLC91.2).  ITBL(91,3),  ITBL(91,4),  ITBL(91,5;, 

1  ITBL(91 ,6)  /2, 2, 6. 1,0, 2/ 

DATA  ITBL(92 , 1 ) ,  ITBL(92,2),  ITBL(92,3),  ITBL(92,4),  ITBL(92,5), 

1  ITBL(92 ,6)  /3, 2, 6, 1.0. 2/ 

DATA  ITBL(93,1),  ITBL(93,2),  ITBL(93,3),  ITBL(93,4),  ITBL(93,5), 

1  ITBLC93.6)  /4, 2, 6,1 ,0,2/ 

DATA  ITBL(94 , 1 ) ,  ITBL(94,2),  ITBL(94,3),  ITBL(94,4),  ITBL(94,5), 

1  ITBLC94.6)  /5, 2, 6, 1,0, 2/ 

DATA  ITBL(95 , 1 ) ,  ITBL(95,2),  ITBL(95,3),  ITBL(95,4),  ITBL(95,5), 

1  ITBLC95.6)  /6, 2, 6, 1,0, 2/ 

DATA  ITSL(96 , 1 ) ,  ITBL(96,2),  ITBL(96,3),  ITBL(96,4),  ITBL(96,5), 

1  ITBL(96,6)  /7.2.6.1 ,0,2/ 

C 

DATA  ITABL  / 1 ,2 . 2 , 3 , 3 ,4 . 5 , 5 ,6 , 7 , 8 , 8 ,9 , 10 . 11 , 1 1 , 12 , 13 , 14/ 

C 

DATA  XNSTAR  / 1 . 0 ,4 . 0 ,2*9 . 0 , 3* 13 .69 , 3* 16 . 0 , 3* 17 .64 , 19 . 36/ 

C 

DATA  JTABL  /I , 2 , 4 ,6 , 7 ,9 , 10 , 11 , 13 , 14 , 15 , 17 , 18 , 19/ 

C 

DATA  TBL  / .49 , . 729 . . 883 , 1 . 004 , 1 . 108 , 1 . 199 , 1 . 283 , 1 . 36 . 1 . 433 , 1 . 502 , 1 

1  .573,1. 630 ,1.690,1.749,1.806,1.861,1.916,1.968,2-020,2.071,2.133, 

2  2.176,2.220,2.268,2.316,2.3639,2.4111,2.4579,2.5046.2.5508,2.5970 

3  , 2 . 6430 , 2 . 6889 , 2 . 7346 , 2 . 7804 , 2 . 8261 ,2.8717.2.9175,2. 9633 , 3 . 0091 , 3 

4  .0551.3.1012,3. 1476 , 3 . 1940 , 3 . 2475 , 3 . 2877 , 3 . 3350 , 3 . 3803 , 3 . 4305 ,3.4 

5  788 , 3 . 5270,3. 5770 , 3 .6260 , 3.6760 , 3.7270 . 3.7780 , 3 . 8300 , 3 . 8820 , 3.935 

6  0,3.9890,4.0440,4.0990,4.1550,4.2130,4.2710,4.3300,4.391,4.453,4. 

7  516,4.580,4.646,4.714,4.783,4.855,4.928,5.004,5.088,5.160,5.245,5 

8  .  332 , 5 . 420 ,5.516.5.614,5.716,5. 824 , 5 . 939 , 6 . 058 ,6.188,6. 326 , 6 . 475 , 

9  6.637,6.815,7.012,7.235,7.491,7.792,8.166,8.654,9.377,9.677,9.977 
$  . 10 . 277 . 10 . 577 . 10 . 877 .11.177,11. 477 ,11. 777 , 12 . 037 , 12 . 377/ 

C 

DATA  SCAX  /.001, .002, .005, . 01 , . 02 , . 05 , . 1 , .2 , . 5 , 1 . , 2 . . 5 . , 10 . , 20 . , 50 
1  ./ 

C 

DATA  SCALE  /2 . 5E9 , 5 . E9 , 1 . E10 , 2 . 5E10 , 5 . E10 , 1 . El 1 , 2 . 5E1 1 , 5 . El 1 , 1 .E12 
1  , 2 . 5E12 , 5 . E12 , 1 . E13 , 2 . 5E13 ,5.E13,1.E14,2.5E14,5.E14,1.E15/ 

C 

DATA  NOEC,  EDGEC ,  EION,  SCRENO,  NGRUP ,  NSUM,  NS PDF ,  NVARM ,  NVARE , 

1  NION.  EBB,  NLEC,  NSNIK  / 10*0 , 200*0 . 1000*0 , 200*0 ., 19*0 , 19*0 , 14*0 , 6 

2  *0,10*0,190*0,2100*0. .150*0,1120*0/ 

C 

DATA  I PLUS ,  IPLUSO ,  KMAX ,  NI ,  R,  XLAM1 ,  XLAM2 ,  ZF1  / 10*0 , 10*0 , 10*0 
1  ,80*0,80*0. .201*0. .201*0. ,10*0./ 

C 

DATA  RERAD  /O./ 
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C 

DATA  AMU2.  CE,  EQSTA ,  GOKE ,  G0KE2 ,  GOVERK,  JB ,  MFLAG .  OMEGA. 

1  PRELAX,  QU,  SD2.  SHEARR,  TRELAX ,  TRELX2,  VAMU .  YY,  22  /6*0..6*C., 

2  6*0. .6*0. ,6*0. ,201*0. ,6*0 , 6*0 , 6*0 . ,6*0. ,201*0. ,201*C. ,6*0. ,6*0. ,6 

3  *0. ,201*0. ,201*0. ,201*0./ 

C 

DATA  KCOUNT  /0/ 

C 

DATA  EM,  IS,  ISM,  ISPALL.  ISPLLM,  JS ,  JTMAX ,  MS,  SJ,  SM,  TMAX , 

1  TSPALL ,  US,  XS  /6*0. ,0,0, 0,6*0, 0,0, 0,0. ,50*0. ,0. ,201*0. ,50*0. ,50* 

2  0./ 

**  THIS  PROGRAM  VALID  ON  FTN4  AND  FTN5  ** 

END 
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•DECK  EDIT 

SUBROUTINE  EDIT 
•IF  DEF.B32 

IMPLICIT  DOUBLEPRECIS lON(A-H.O-Z) 

•ENDIF 


* _ * _ * _ * _ * _ * _ * _ * _ * _ » _ » 


IMPORTANT  VARIABLES  LOCAL  TO  THIS  SUBROUTINE 

DTPP  PULSE  WIDTH  IN  SECONDS  AT  HALF  HEIGHT  OF  THE 

PULSE  CONTAINING  SMAX  —  COMPUTED  USING  THE 
EXPRESSION  EMVPP/SMAX 

DTPULS  A  PULSE  WIDTH  TERM  IN  SECONDS,  COMPUTED  USING 

THE  EXPRESSION  EMVPL/SMAX 

EMVBM  THE  SUM  OF  THE  MAXIMUM  POTENTIAL  MOMENTUM  IN 

DYNE-SECONDS/CM* *2  OF  VAPORIZED  REGION  — 
SUBLAYER  REGIONS  THAT  ARE  VAPORIZED  ARE  NOT 
CONSIDERED.  —  THE  ENERGY  E  AVAL I ABLE  FOR  THE 
MAXIMUM  MOMENTUM  OF  THE  ZONE  IS  DEFINED  AS 
E-0.5*U**2+(£-ESUB)  WHERE  ESUB  IS  THE 
SUBLIMATION  ENERGY  —  THE  VELOCITY  U  ASSOCIATED 
WITH  THE  MAXIMUM  POTENTIAL  MOMENTUM  IS  DEFINED 
AS  E-0 . 5*U* *2  OR  U-SQRT(2*E)  —  HENCE  THE 
MAXIMUM  POTENTIAL  FOR  A  VAPORIZED  ZONE  IS 
ZM*SQRT(U*  *2+2*(E«ESUB) ) 

EMVNEG  TOTAL  NEGATIVE  MOMENTUM  IN  DYNE -SECONDS/ CM* *2  IN 

A  MESH  --  THIS  EXPRESSION  IS  COMPUTED  BY 
AVERAGING  THE  VELOCITIES  OF  TWO  ADJACENT  ZONE 
BOUNDARIES  AND  USING  THE  MASS  OF  THE  ZONE 
BETWEEN. 

EMVPL  SUM  OF  THE  MOMENTUM  OF  EACH  ZONE  FROM  JSMAX+3 

BACK  TO  THE  FIRST  ZONE  WHICH  HAS  A  NEGATIVE 
VELOCITY . 

EMVPOS  TOTAL  POSITIVE  MOMENTUM  IN  A  MESH  —  CALCULATED 

LIKE  EMVNEG 

EMVPP  SUM  OF  EMVPL  AND  EMVPR 

EMVPR  SUM  OF  THE  MOMENTUM  OF  EACH  ZONE  FROM  JSMAX+4 

TO  JSTAR+1 

ETOTAL  TOTAL  ENERGY  IN  CALORIES  COMPUTED  BY  SUMMING  THE 

KINETIC  AND  INTERNAL  ENERGY  OF  ALL  ZONES. 

JQMAX  ZONE  NUMBER  OF  THE  ZONE  HAVING  THE  LARGEST 

VALUE  OF  ARTIFICIAL  VISCOSITY,  Q. 

JSMAX  ZONE  NUMBER  OF  THE  ZONE  HAVING  THE  LARGEST 

STRESS . 

JTS  ZONE  NUMBER  OF  THE  ZONE  HAVING  THE  SMALLEST 

STABLE  HYDRO  TIME 

PDTNEG  INTEGRATED  NEGATIVE  MOMENTUM  FOR  THE  LAST 

JEDIT  ZONE  —  IT  IS  THE  SUM  OF  ALL  NEGATIVE 
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C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 

•CALL 


PDTPOS 

QMAX 

SMAX 

X(JSMAX) 

X(JQMAX) 


(S+0)*DTNH  TERMS  FOR  THAT  ZONE 
INTEGRATED  POSITIVE  MOMENTUM  FOR  THE  LAST 
JEDIT  ZONE 

THE  MAXIMUM  ARTIFICIAL  VISCOSITY  IN  DYNES/CM* *2 
IN  THE  MESH 

THE  MAXIMUM  STRESS  IN  THE  MESH 
EULERIAN  COORDINATE  IN  CENTIMETERS  OF  THE 
BOUNDARY  OF  THE  ZONE  WITH  MAXIMUM  STRESS 
EULERIAN  COORDINATE  IN  CENTIMETERS  OF  THE 
BOUNDARY  OF  THE  ZONE  WITH  MAXIMUM  ARTIFICIAL 
VOSCOSITY 


SYMBOL  DESIGNATIONS  ON  LOG  PLOTS 


NEGATIVE  ABSCISSA 
POSITIVE  ABSCISSA 
NEGATIVE  STRESS 
POSITIVE  STRESS 
VISCOSITY 

NEGATIVE  PARTICLE  VELOCITY 
POSITIVE  PARTICLE  VELOCITY 
SPECIFIC  ENERGY 
ZONE  SIZE 
TEMPERATURE 
ZONE  IONIZATION 
COMPRESSED  VOLUME 
EXPANDED  VOLUME 


i  BLANK 
^  AA 
j  EQED 
j  EQVP 
,  PLOTCM 
,  RZCOM 
j  SPLLC 

DIMENSION  A( 120) .  EMVN(6),  ZZCTRL(40) 

DIMENSION  JP(5) ,  JQMAX(6) ,  JSSMAX(6) ,  JTTMAX(6),  KP(5),  QMAXC6) , 

1  QS(201),  SQC201),  SSMAXC6),  TTMAXC6) 

DATA  BLANK,  CONI,  CON2 ,  CONS,  C0N4 ,  CON5 ,  C0N6,  C0N7,  C0N8 ,  C0N9 . 

1  CONIO,  CONI 1 ,  CON 12 ,  CON13,  C0N14,  CON15,  CON16  /'  '.'W'.'X'.'S', 

2  'N','Q','U','T'.'E',‘D','H','Z','M','L','-'t'B','+'/ 

DO  10  1-1,5 
JPCI)-JBND(I) 

KP(I)-0 
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10  CONTINUE 
JJJ-JFIN-1 
TT-TIME* 1 . E6 
DO  20  J-2, JFIN 
QS(J)-Q(J)*l.£-g 
SQ(J)-S(J)*l.E-9 
20  CONTINUE 

WRITE  Cl)  N,TT, JJJ.NMTRLS , (X( J) ,SQ( J) ,QS( J) .  J-2, JFIN) , JP, JJJ.KP 
IF  (WTAPE)  30,60,30 
30  CONTINUE 

WRITE  (6,1110) 

WRITE  (6,1230)  (DISCPT(I) ,1-1 ,8) 

WRITE  (6,1210)  N.TIME 
WRITE  (6,1220) 

LINE-9 

J 1 -MAXO ( JHAT , JSTAR ) 

DO  40  J-l.Jl 

WRITE  (6,1180)  J,CS(J),V(J),E(J),P(J),S(J), SD( J) ,U(J),ZM(J) , TEMP( J 

1  ) , ZFM( J) , X( J) ,Q( J) ,QO( J) ,DV(J),EI(J) , ITER( J) ,F( J) , FO( J ) , EADD( J ) 

2  ,  TSPALL(  J) 

LINE-LINE +4 

IF  (LINE. LT. 50)  GO  TO  40 
WRITE  (6,1110) 

WRITE  (6,1220) 

LINE-4 
40  CONTINUE 

JSTARD-MINO( Jl+1 , JFIN) 

WRITE  (6,1060) 

ZMAS-0 , 

DO  50  J-2, JFIN 
ZMAS-ZMAS+ZM(J) 

WRITE  (6,1070)  PX( J) , ZM( J) , ZHAS ,E( J) 

50  CONTINUE 
60  CONTINUE 

JSTARD-MINOC JSTAR+1 , JFIN) 

C 

C  TOTAL  MOMENTUM  CALCULATION 

C 

EMVNEG-0 . 

EMVPOS-O . 

DO  70  1-1,6 
EMVN( I )-0 . 

JQMAXC I ) »JBND( I ) 

JSSMAX(I)-JBND(I) 

JTTMAX( I ) - JBND( I ) 

QMAX( I ) -0 . 

SSMAX( I ) -0 . 

TTMAX ( I ) -0 . 

EMVN( I )»0 . 0 
70  CONTINUE 
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CALCULATE  LAYER  MOMENTA,  TOTAL  MOMENTUM  IN  MESH,  AND  ESTIMATE  0 
LATE  TIME  TRANSVERSE  LINE  LOAD  (XNL) 

ESUM-0 . 

EKSUM-0 . 

XNL-O. 

M«1 

MS-1 

DO  190  J-2, JSTARD 
IF  (J-I.EQ.JBND(M))  M-M+l 
IF  (Q(J)-QMAX(M))  90,90,80 
80  CONTINUE 

QMAX(M)-Q(J) 

JQMAX(M)-<J 
90  CONTINUE 

DXX-X(J)-X(J-1) 

IF  (TSPALLC J) .N£. 1 .234)  GO  TO  100 
DXX-X(MS)-XCJ-l) 

EMV- . 5*ZM( J)* (US(MS)+U( J-l ) ) 

MS-MS+1 
GO  TO  110 
100  CONTINUE 

EMV- . 5*ZM( J) * (U( J)+U( J-l ) ) 

110  CONTINUE 

SL-1 . 5*SD( J)+6 . 0*G0VERX( J) *S( J)/ (3 . 0+4 . 0*G0VERK( J) ) 

IF  (TSPALLC J) . EQ . 8 . . OR .TSPALLC J) .EQ . 7 - )  SL-O. 

XNL-XNL+SL*DXX 
IF  (EMV)  120,130,130 
120  EMVNEG-EMVNEG+EMV 
EMVN ( M ) -EMVN ( M ) +EMV 
GO  TO  140 

130  EMVPOS-EMVPOS+EMV 
EMVN ( M ) -EMVN ( M ) +EMV 
140  CONTINUE 

CALCULATE  MAXIMUM  STRESS  AND  MAXIMUM  TENSION  FOR  EACH  MATERIAL 


IF  (SSMAX(M)-S(J))  150,160,160 
150  CONTINUE 

SSMAX(M)-SCJ) 

JSSMAX(M)-«J 
160  CONTINUE 

IF  ( TTMAX (M)+S(J))  170,180,180 
170  CONTINUE 

TTMAX ( M ) « ABS ( S  (  J ) ) 

JTTMAX(M)-J 
180  CONTINUE 
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C  TOTAL  ENERGY  CALCULATION  (IN  CALORIES) 

C 

ESUM-ESUM+(E( J)-7 . 5E10/XMW(M) *FLOAT(NATOM(M) ) ) *ZM( J) /4 . 186E7 
EXSUM-EKSUM+ZM( J)*(U(J-1)**2+U( J-1)*U( J)+U( J)**2)/4 . 186E7/6. 
190  CONTINUE 

ETOTAL-ESUM+EXSUM 

JM-JSMAX+3 

C 

C  CALCULATE  MOMENTUM  OF  MAIN  PULSE 

C 

EMVPL-0 . 

200  EMVPL-EMVPL+UC  JM) * . 5* ( ZM( JM+1 )+ZM( JM) ) 

IF  (JM-JSMAX)  210,220,220 
210  CONTINUE 

IF  ( JM-1 )  230,230,220 
220  CONTINUE 
JM-JM-1 

IF  (U( JM))  230,230.200 
230  JM-JSMAX +4 
C 

C  CALCULATE  MOMENTUM  OF  PRECURSOR 

C 

EMVPR-0 . 

240  EMVPR-EMVPR+UC JM) /2 . *(ZM( JM)+ZM( JM+1)) 

IF  (JM-JSTAR)  250,250,260 
250  JM-JM+1 
GO  TO  240 

260  EMVPP -EMVPL+EMVPR 
DTPP-EMVPP/SMAX 
DTPULS -EMVPL/ SMAX 
C 

C  CALCULATE  MAXIMUM  POTENTIAL  MOMENTUM  OF  VAPOR 

C 

M-l 

EMVBM-0 . 

EM VBM 1-0.0 
EMVBM2-0. 

DO  280  J-2 , JSTARD 

IF  ( J-l .EQ. JBND(M))  M-M+l 

DE-E( J )-7 . 5E10/ XMW ( M ) *  FLOAT ( N ATOM (M) )- EQSTE ( M ) 

IF  (DE)  290,290,270 

270  UAVG-( SQRTCU( J-l ) *U( J-l )+2 . *DE)+SQRT(U( J )*U(J)+2. *DE))/2. 
EMVBK -EMVBM+UAVG * ZM ( J ) 

UAVG- ( U ( J- 1 ) +U  C  J ) ) / 2 . 0 
EM VBM 1 -EMVBM 1 +UAVG *  ZM ( J ) 

UAVG1 «-ABS(U( J-l ) ) *U( J-l )+2 . *DE 
•IF  DEF.B64 

X1-SIGN( 1 .O.UAVGl) 

UAVG2*-ABS(U( J ))*U(J)+2. *DE 
X2-SIGN( 1 .0.UAVG2) 
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•ENDIF 
•IF  DEF.B32 

Xl-DSIGNU .D0.UAVG1) 

UAVG2— ABS(U(J)  )*U(  J)+2  .  *DE 
X2-DSIGNC 1 .DO ,UAVG2) 

•ENDIF 

UAVG- ( XI • SQRTC  XI *UAVG1 )+X2  *  SQRT( X2  *UAVG2 ) ) / 2 . 0 
280  EMVBM2  »EMVBM2+UAVG *  ZM ( J ) 

290  CONTINUE 

PUT  TIME  HISTORY  OF  MOMENTUM  AND  RERADIATION  ON  SEPARATE  FILE 
RATHER  THAN  IN  DAYFILE. 

WRITE  (9,1170)  TIME , EMVBM , EMVBM 1 , EMVBM2 , EMVNEG , EMVPOS , RERAD 
PRINT  OUTPUT  VARIABLES 


DTNR-0 . 9/DTRC 
JBND1 - JBND( 1 ) 

JBND2-JBNDC2) 

JBND3-JBNDC3) 

WRITE  (6,1190) 

WRITE  (6,1080)  N, JFIN.JSTAR.JTS, TIME, DTNH,X(1), EMVNEG, EMVPOS, XNL 
1  .ETOTAL 
WRITE  (6,1090) 

DO  300  M-l , NMTRLS 
Jl-JBND(M) 

J2-JSSMAX(M) 

J3-JTTMAX(M) 

J4-JQMAX(M) 

WRITE  (6,1100)  J1,J2,J3,J4,X(J1),X(J2),X(J3),X(J4),SSMAX(K),TTMAX 
1  (M) ,QMAX(M) ,EMVN(M) 

300  CONTINUE 
JS1-2 

JS2-JSTARD/3 
JS3-2* JS2 
JS4-JSTARD 

IF  ( ILOG)  630,310,630 
310  CONTINUE 

WRITE  (3,1120)  (DISCPT( I),I»1,8),JS1, JS2 , JS3 , JS4 , S( JS1 ) , S( JS2 )  , S 

1  ( JS3) ,S( JS4) ,U( JS1) ,U( JS2) ,U( JS3) ,U( JS4) ,E(JS1) ,E( JS2) ,E( JS3) ,E 

2  ( JS4 ) , V( JS1) ,V( JS2) , V( JS3) , V( JS4) , X( JS1 ) , X( JS2) , X( JS3) , X( JS4 ) 

3  , TEMP( JS1 ) ,TEMP( JS2) ,TEMP( JS3) ,TEMP( JS4) , ZFM( JS1 ) , ZFM( JS2) , ZFM 

4  ( JS3) , ZFM( JS4) , ( JBND(M) , M»1 ,6) 

PREPARE  LOG  PLOTS 

DO  320  J-1,120 
A( J) -BLANK 
320  CONTINUE 
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JSSTAR-MINO ( JSTARD+ 1 0 , JFIN) 

M-l 

DO  620  J-2.JSSTAR 
IF  (X(J))  330,350,340 
330  CONTINUE 
*IF  DEF.B64 

NX-120. 5+28. *(AM0D(AM0D(AL0G(ABS(X(J)))/2. 3025851, 4. )+4. ,4. )-4. ) 

•ENDIF 
•IF  DEF.B32 

NX-120.5+28. *(DMOD( DM0D(DL0G(ABS(X(J)))/2. 302585100,4. DO )+4. DO, 4 
1  .  DO  )  -4 .  DO  ) 

•ENDIF 

A (NX) -CONI 
GO  TO  350 
340  CONTINUE 
•IF  DEF.B64 

NX-20.5+100. *AM0D((2.0*ABS(X(J))),1. ) 

•ENDIF 
•IF  DEF.B32 

NX-20.5+100. *DMOD((2.DO*ABS(X(J))) ,1.D0) 

•ENDIF 

A( NX) -C0N2 

350  IF  (S(J))  360,390,360 
360  CONTINUE 
•IF  DEF.B64 

NX-120. 5+28. *(AMOD(AMOD(ALOG(ABS(S(J))+.0001)/2. 3025851, 4. )+4. .4. ) 
1  -4.) 

•ENDIF 
•IF  DEF.B32 

NX-120 . 5+28 . * ( DMOD(DMOD(DLOG( ABS( S( J ) )+l .D-4)/2 . 302585 IDO ,4 . DO) +4 
1  .  DO  ,  4 .  DO  )  -4 .  DO  ) 

•ENDIF 

IF  (S(J))  380,370,370 
370  A( NX ) -C0N3 
GO  TO  390 
380  A(NX)-C0N4 

390  IF  (Q(J).EQ.O.O)  GO  TO  400 
•IF  DEF.B64 

NX-120.5+28. *(AMOD(AMOD( ALOG(Q(J)+. 0001 )/2. 3025851 ,4. )+4. .4. )-4. ) 

•ENDIF 
•IF  DEF.B32 

NX-120 . 5+28 . * ( DM0D( DMOD(DLOG( Q( J)+l . D-4 ) /2 . 3025851D0 , 4 . DO )+4 . DO . 4 
1  .  DO  )  -4  .  DO  ) 

•ENDIF 

A(NX)-C0N5 

400  IF  (U(J))  410,440,410 
410  CONTINUE 
•IF  DEF.B64 

NX-120.5+28. *(AMOD(AMOD(ALOG(ABS(U(J))+.0001)/2. 3025851 ,4. )+4. ,4. ) 
1  -4.) 
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•ENDIF 
•IF  DEF.B32 

NX-120. 5+28. *(DM0D(DM0D(DLOG(ABS(U(J))+l.D-4)/2.3025851D0, 4. D0)+4 
1  .DO ,4 .D0)-4 .DO) 

•ENDIF  ,  •• 

IF  (UfJ))  430.420,420 
420  A ( NX ) -C0N6 
GO  TO  440 
430  A(NX)-C0N7 
440  IF  (E( J) )  450,460,450 
450  CONTINUE 
•IF  DEF.B64 

NX-120. 5+28. •(AMOD(AMOD(ALOG(ABS(E(J))+. 0001 )/2. 3025851, 4. )+4. ,4.  ) 
1-4.) 

•ENDIF 
•IF  DEF.B32 

NX-120 . 5+28 . * (DMOD(DMOD(DLOG( ABS(E( J) )+l .D-4)/2 . 302585 IDO ,4 .DO )+4 
1  .DO ,4 .DO) -4 -DO) 

•ENDIF 

A(NX)-C0N8 
460  DXX-XCJ)-X(J-l) 

IF  (DXX)  480,480,470 
470  CONTINUE 
•IF  DEF.B64 

NX- 1 20 . 5+28 . • C  AMOD  C  AMODC  ALOGC DXX ) / 2 . 302585 1 , 4 . ) +4 . , 4 . ) -4 . ) 

•ENDIF 
•IF  DEF.B32 

NX- 120 . 5+28 . • ( DMODC DMODC DLOGC DXX ) / 2 . 30258 5 IDO , 4 . DO ) +4 . DO , 4 . DO ) -4 
1  .DO) 

•ENDIF 

A(NX)-C0N9 

480  IF  (TEMP(J))  500.500,490 
490  CONTINUE 
•IF  DEF.B64 

NX-120. 5+28. 0*(AMOD( AM0D( ALOG(TEMP( J)+ . 0001 ) /2 . 3025851 ,4. )+4. ,4. )- 
1  4.) 

•ENDIF 
•IF  DEF.B32 

NX- 120 . 5+28 . 0* (DMODC DMODC  DLOGC  TEMPC  J)  + 1 . D-4 ) / 2 . 302585 IDO , 4 . DO ) -4 
1  .  DO  ,  4 .  DO  )  -4 .  DO  ) 

•ENDIF 

A(NX)-CON10 
500  CONTINUE 
•IF  DEF.B64 

NX-8. 5+AM0D(ZFM(J) ,112.0) 

•ENDIF 
•IF  DEF.B32 

NX-8 . 5+DMODC  ZFM( J) , 1 12 . DO) 

•ENDIF 

A (NX) -CONI 1 
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IF  (V(J)-l.)  510,510,520 
510  CONTINUE 
•IF  DEF.B64 

NX-120. 5+28. *(AMOD(AMOD(ALOG( . 01 •( 1 . /V(J)- .99) )/2 . 3025851 ,4. )+4. ,4 
1  •  ) -4 .  ) 

•ENDIF 

•IF  DEF.B324 

NX- 120 . 5+28  .  * (DMOD(DMOD(DLOG(  1  .  D-2*  (  1  .D0/V(  J)-9 .9D-1 )  ) /2 . 302585 IDO 
1  , 4  .  DO  )  +4 .  DO  ,  4 .  DO  )  -4  .  DO  ) 

•ENDIF 

A( NX) -CONI 2 
GO  TO  530 
520  CONTINUE 
•IF  DEF.B64 

NX-120. 5+28. *(AM0D( AM0D( ALOG( 1 ./V(J))/2. 3025851 ,4. )+4 . .4. )-4 . ) 

•ENDIF 
•IF  DEF.B32 

NX- 120 . 5+28 . • C DMOD( DMODC DLOGC 1 . DO/ V( J) ) /2 . 302585 IDO , 4 . DO ) +4 . DO . 4 
1  .  DO  )  -4 .  DO  ) 

•ENDIF 

A( NX) -CONI 3 

530  IF  (JBND(M)-J)  570,540,570 
540  M-M+l 

DO  560  1-8,120 
IF  (AC I) -BLANK)  560.550,560 
550  A(  I  )-C0H14 
560  CONTINUE 

A( 15 )-CON15 
A( 105) -CONI 5 

570  IF  (MOD(J.IO))  600,580,600 
560  DO  590  1-8,120,28 
A( I )-C0N16 
590  CONTINUE 

WRITE  (3,1130)  J,(A(I),I-8,120) 

GO  TO  610 

600  WRITE  (3,1140)  ( A( I ) , 1-1 . 120 ) 

610  DO  620  1-1,120 
620  A( I) -BLANK 

END  PREPARE  LOG  PLOTS 

PREPARE  LINEAR  PLOTS  OF  S  VS  X 

630  IF  (ILIN)  1050,640,1050 
640  MX-0. 

MP-0. 

KPLUS-0 
XINC-100. 

M-l 

JJ-JBNDC 1 ) 


A-  37 


HYPUF  SOURCE  LISTING 


IF  (JJ)  650,650,660 
650  JJ-JFIN 

660  JM-MIN0( JSTAR+2, JFIN+1) 

670  JM-JM-1 

IF  (ABS(S( JM) )- .01 *ABS( SMAX) )  670,670,680 
680  JM-MIN0(JM+1,JFIN) 

JT-1 

690  JT-JT+1 

IF  ( ABS( S( JT) )- . 01 *ABS( SMAX) )  690,690,700 
700  JT-JT-1 

JT-MAXOC  JT.2) 

710  MP-MP+1 

IF  ( ABS ( SMAX )- SCALE (MP))  720.720,710 
720  PWX-X( JM)-X(JT) 

730  MX-MX+1 

IF  ( PWX-SCAX(MX) )  740,740,730 
740  DSCAX-SCAX(MX)/XINC 

*  IF  DEF.B64 

XPES-FLOAT(IFIX(X(JT)/DSCAX))*DSCAX 

•ENDIF 

*  IF  DEF  B32 

XPES-FLOAT( IDINT(X( JT)/DSCAX) )*DSCAX 

•ENDIF 

SCX-SCAX(MX) 

SCY  "SCALE (HP) 

WRITE  (3,1160)  (DISCPT( I  )  ,  1-1 , 8 ) , N .TIME , SCALE(MP) , XPES  • 
GO  TO  760 
750  JT-JT+1 

IF  (JT.GE.JFIN)  GO  TO  1050 
760  XAVG-(X( JT+1 )+X( JT) )/2 . 

IF  ( XAVG-X( JFIN ) )  770,1050,1050 
770  IF  (XAVG-XPES)  750,780,780 
780  DELX-C  X( JT+1 )-X( JT-1 ) ) /2 . 

IF  (JT.EQ.l)  DELX-(X( 2 )-X( 1 ) )/2 . 

IF  (DELX)  790,790,800 
790  SC-0. 

GO  TO  810 

800  Dl-CDELX-XAVG+XPES) 'DELX 

SC-S( JT)+(S( JT+1)-S(JT))*D1 
810  IF  (Q( JT)+Q( JT+1 ) )  830.830,820 
820  QQ-SC+QC JT)  +  (Q( JT+1 )-Q(JT))*Dl 
*IF  DEF.B64 

NX -60 . 5+AMODC  50 . *QQ / SCALE (MP ) , 50 . ) 

•ENDIF 
•IF  DEF.B32 

NX -60 . 5+DMODC5 .DO* QQ/ SCALE (MP) . 5 .DO) 

•ENDIF 

A(NX)-C0N5 

830  NX-60.5+50. *SC/SCALE(MP) 

NX-MAXO(NX.l) 
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NX«MIN0(NX,120) 

A (NX) -CONS 

IF  (A( 60) -BLANK)  850,840,850 
840  A(60)-CON16 
850  KSW-1 

IF  (KPLUS-5)  890,860,890 
860  KPLUS-0 
KSW-2 

DO  880  1-10,110,10 
IF  (A(I)-BLANK)  880,870,880 
870  A( I )-C0N16 
880  CONTINUE 
890  KPLUS-KPLUS+1 
XPES-XPES+DSCAX 

900  IF  ( XPES-XC JJ ) )  1000,950,910 
910  IF  (XPES-DSCAX-X(JJ))  950.950.920 
920  M-M+l 

M-MINO(M.NMTRLS) 

JJ-JBND(M) 

IF  (JJ)  940,930.940 
930  JJ-JFIN 
940  GO  TO  900 
950  M-M+l 

M-MINO(M.NMTRLS) 

DO  970  1-10,110 
IF  (A( I) -BLANK)  970,960,970 
960  A( I)-C0N14 
AC 15)-CON15 
A(105)-CON15 
970  CONTINUE 
JJ-JBND(M) 

IF  (JJ)  990,980,990 
980  JJ-JFIN 
990  CONTINUE 

1000  GO  TO  (1020,1010),  KSW 
CALL  GOTOER 

1010  WRITE  (3,1150)  XPES , ( A( I ) , 1-10 , 1 10) 

GO  TO  1030 

1020  WRITE  (3,1140)  ( A( I ) , 1-1 , 1 10) 

1030  DO  1040  1-1,110 

1040  A( I ) -BLANK 

IF  (XPES-X(JM))  760,1050,1050 

1050  WRITE  (3,1200) 

RETURN 

C 

1060  FORMAT  ( 1H0 . 8X , 2HPX , 8X , 2HZM ,6X , 4HZMAS ,9X , 1HE/ ) 

1070  FORMAT  ( 5X , 1P4E10 . 3) 

1080  FORMAT  ( // , 5X, 5HCYCLE , 2X , 4HJFIN , IX , 5HJSTAR , 3X , 3HJTS ,6X , 4HTIME  ,6X  ,  4 
1  HDTNH , 6X , 4HX( 1 ) , 4X , 6HEMVNEG , 4X , 6HEMVP0S , IX , 9HLINE  LOAD , 4X , 6HET0TA 
2L/5X ,3(15, IX), 15, 1P7E10 . 3) 
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1090  FORMAT  ( /6X , 4HJBND , IX , 5HJSMAX, IX , 5HJTMAX , IX , 5HJQMAX . 3X , 7HX( JBND) . 2 

1  X,8HX( JSMAX) . 2X,8HX( JTMAX) , 2X , 8HX( JQMAX) , 6X , 4HSMAX , 6X , 4HTMAX , 6X , 4 

2  HQMAX , 2X . 8HM0MENTUM ) 

1100  FORMAT  (4X,4( IX, 15) , 1P8E10 • 3) 

1110  FORMAT  (1H1) 

1120  FORMAT  C/1X,8A10/5H  ZONE , 7X , 4( 13 , 9X)/4H  S  .4E12.3/4H  U  .4E12.3/4 

1  H  E  .4E12.3/4H  V  ,4E12.3/4H  X  .4E12.3/5H  TEMP.4E12 . 3/4H  ZF  ,4E 

2  12 . 3//15H  BOUNDARIES  AT  .6I4//52H  LINEAR  X  PLOT,  FULL  SCALE-0.5  C 
3M  (100  PRINT  WHEELS ) / IX , 31HLINEAR  ZF  PLOT,  FULLSCALE  -  112//1H0.4H 
4Z0NE , 2X , 4H10-4 , 23X , 4H10-3 , 24X , 4H10-2 , 24X , 4H10-1 . 25X , 1H1 / 1H  , 6X , 1H* 
•5  , 27X , 1H+ , 27X , 1H+ . 27X , 1H+ , 27X , 1H+ ) 

1130  FORMAT  ( 1H  , 14 , 2X , 1 13A1 ) 

1140  FORMAT  (120A1) 

1150  FORMAT  ( 1H  , F7 . 4 , IX , 101A1 ) 

1160  FORMAT  (27H1PL0T  OF  LINEAR  STRESS  VS  X/1H  ,8A10.11H  CYCLE  NO . - . 14 , 
1  10X, 5HTIME- , E10 . 3/ 14H  TOP  OF  PAGE  -,E12.3,24H  DYNES / SQUARE  CENTIM 
2ETER/ / 1H0 ,6X ,4H-2 . 5 ,6X . 4H-2 . 0 ,6X ,4H-1 . 5 ,6X , 4H-1 . 0 , 6X , 4H-0 . 5 ,6X , 4H 
30 . 0 , 7X , 3H0 . 5 , 7X , 3H1 . 0 , 7X , 3H1 . 5 , 7X , 3H2 . 0 , 7X , 3H2 . 5 / 1H0 , 6X , 4H-5 . 0 , 6X , 

4  4H-4 . 0 , 6X , 4H-3 . 0 , 6X , 4H-2 . 0 , 6X , 4H- 1 . 0 , 7X , 3H0 . 0 , 7X , 3H1 . 0 , 7X , 3H2 .0,7 

5  X , 3H3 . 0 , 7X, 3H4. 0 , 7X, 3H5 . 0/ 1H0 , 5X , 5H-10 . 0 ,6X , 4H-8 . 0 ,6X ,4H-6 . 0 ,6X , 4 

6  H-4 . 0 , 6X , 4H-2 . 0 , 7X , 3H0 . 0 , 7X , 3H2 . 0 , 7X , 3H4 . 0 , 7X , 3H6 . 0 , 7X , 3H8 . 0 , 6X , 4 

7  H10 . 0/ 1H0 , F7 .4 , IX , 1H+ , 10(9X , 1H+)  ) 

1170  FORMAT  ( IX , 1P7E12 . 3) 

1180  FORMAT  ( / /5X , 15 , 1P10E12 .4/ 10X, 1P5E12 . 4 . 112 . 1P4E12 .4) 

1190  FORMAT  ( 1HQ) 

1200  FORMAT  ( 1HR) 

1210  FORMAT  (20H  TIME  EDIT  AT  CYCLE , 15 , 5X , 5H  TIME , 1PE15 . 5 . 4H  SEC//) 
1220  FORMAT  (//6X.2H  J.6X.3H  CS,10X,2H  V.10X.2H  E.10X.2H  P,10X,2H  S,9X, 

1  3H  SD.10X.2H  U,9X,3H  ZM , 8X , 5H  TEMP.8X.4H  ZFM/15X.2H  X,10X,2H  Q.9X 

2  ,3H  Q0.9X.3H  DV.9X.3H  EI.8X.5H  ITER.9X.2H  F.9X.3H  F0,8X,5H  EADD , 6 

3  X , 7H  TSPALL) 

1230  FORMAT  (1H0.T26, 8A10) 

END 
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•DECK  EQST 

SUBROUTINE  EQST 
•IF  DEF.B32 

IMPLICIT  DOUBLEPRECISION(A-H.O-Z) 

•ENDIF 

C 

•CALL  BLANK 
•CALL  AE 
•CALL  EQED 
•CALL  EQFL 
•CALL  EQVP 
•CALL  HTEQ 
•CALL  INDX 
•CALL  PLOTCM 
•CALL  RZCOM 
•CALL  SPLLC 

C  THIS  SUBROUTINE  CALCULATES  NEW  TEMPERATURES  IN  THE  MESHES  BY 
C  MAKING  ITERATIVE  GUESSES. 

C 

M-l 

NCOUNT-O 

J 1 -MAXO ( JSTAR , JHAT ) 

C 

C  MAKE  FIRST  GUESS  AT  NEW  TEMPERATURES  IN  THE  MESHES 
C 

FO(l)-F(l) 

DO  200  J-2.JFIN 
IF  (J-l.EQ.JBND(M))  M-M+l 
ZFMC J ) -ZFM( J ) / FLOATC NATOM( M) ) 

FO(J)-FCJ) 

TKEEP(J)-TEMP(J) 

IF  (IFLOW.NE.O)  F(J)-0.0 
P(J)-P(J)+Q(J)+QO(J) 

ITERC J)«4 

IF  (IDIF.EQ.O)  ITER(J)-1 
IF  CICON.EQ.O)  ITERC J) -2 
IF  CICON.EQ.O. AND. IDIF.EQ.O)  ITERC J)-3 
IF  ( TIME . GT . SSTOPM )  GO  TO  190 
DEDTP-1 . 25E8/XMW(M) • FLOATC NATOM(M) ) 

DPDTP-8 .31E7/XMWCM)/VCJ)’FLOATCNATOMCM)) 

DELRO-1 ./VC J)-l ./CVCJ)-DVCJ)) 

ZSTAR-0 . 0 

IF  CZFMCJ) .GT. 10.0)  ZSTAR-ZFMCJ) 

NEM-NELEMC  m ) 

XNATOM -6 . 02  E23 / XMW  C  M ) / V  C  J ) *  FLOAT  C  N ATOM  CM)) 

XN 1 -2 . 43E 1 5 / XN ATOM 
ENU-1 ,/VCJ)/RH0CM) 

IF  CENU.LT.l.)  GO  TO  10 
C 
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MATERIAL  IS  COMPRESSED 
Wl-2.0 

W2-3.*EQSTG(M) 

DES1-0.0 
GO  TO  90 

MATERIAL  IS  EXPANDED 

10  ALF-EQSTH(M)+(EQSTG(M)-EQSTH(M) )*SQRT(ENU) 

IF  (ABS(ALF-EQSTH(M))  .LE-.  l.E-3)  GO  TO  20 
GO  TO  30 
20  Wl-I. 

GO  TO  40 

30  Wl«2 . *  (EQSTG(M)-ALF) / ( ALF-EQSTH(M) ) 

Wl«(2 . +W1 ) / ( 1 . +W1 ) 

40  W2*l . 5*ALF*W1 

Vl«(V(J)-DV(J))*RHO(M) 

ENU2-EQSTN(M)*(1 .-V1)«V1 
IF  (ENU2.LT.-10.0)  GO  TO  50 
ES 10-EQSTE C  M ) * ( 1 . -EXP ( ENU2 ) ) 

GO  TO  60 

50  ESIO-EQSTE(M) 

60  Vl-VCJ)’RHO(M) 

ENU2-EQSTN(M) * ( 1 . -VI ) «V1 
IF  (ENU2.LT.-10.0)  GO  TO  70 
ES1N-EQSTECM) *  C 1 . -EXP(ENU2) ) 

GO  TO  80 
70  ESIN-EQSTE(M) 

80  DES1-ES10-ES1N 

FIRST  GUESS  AT  NEW  TEMPERATURES 

90  TEMPJ-TEMP(J) 

IF  (ZFM(J) .GT.10.0)  GO  TO  110 
ITRT-1 

100  ZSTAR-ZSTAR+1 

110  DEDT-DEDTP  * ( VI +3 . *  ZSTAR ) 

DPDT -DPDTP  * ( V2+2 . *  ZSTAR ) 

TEMPJ-(TEMP( J)‘DEDT+EADD( J)+DES1-CQ( J)+Q0(J))/2. *DV( J))/(DEDT-V( J) 
1  *  *  2  *  DPDT  *  DELRO ) 

TEMP J«TEMP J+ ( FOC  J ) -F0( J- 1 ) ) * DTNH/ ZM ( J ) / ( DEDT-V( J ) *  *  2  *DPDT*  DELRO ) 

IF  (TEMPJ.LT. 300.0)  TEMPJ-300.0 
IF  ( TEMP ( J ) . LT . 1 . 2E4 )  GO  TO  180 
IF  (ZFM(J) .GT. 10.0)  GO  TO  180 
IF  (ITRY.EQ.2)  GO  TO  180 
XTEV-TEMP J/ 1 . 16E4 
FXPC-XNi *TEMPJ* *1.5 
ZSTAR1-0.0 
DO  170  Nl-l.NEM 
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N2-IELEM(M,N1) 

NT-NTBL(N2) 

DO  120  X-l.NT 
C  AVOID  EXP  UNDERFLOW 

ARGEXP— XI  (  N2 ,  X  )  /XTEV 
EXPR-0 . 0 

IF  ( ARGEXP. GT. -675.)  EXPR«EXP( ARGEXP) 

XP -FXPC  *  EXPR 

IF  (XP .LT.FLOAT(K) )  GO  TO  130 
120  CONTINUE 
130  K-K-l 

DO  160  Kl-1.10 
IF  (K.EQ.O)  GO  TO  140 

XITMP«XI(N2 ,K)+FL0AT(K1 )/10.0*(XI(N2 , K+l )-XI(N2 ,K) ) 

GO  TO  150 

140  XITMP-FLOAT(K1)/10.0*XI(N2,1) 

150  XP*FXPC*EXP( -XITMP/XTEV) 

IF  (XP .LT . FLOAT(K)+FLOAT(K1 )/ 10 . 0)  GO  TO  170 
160  CONTINUE 

170  ZSTAR1«ZSTAR1+AF(M ,N2) * (FL0AT(X)+FL0AT(K1-1 )/ 10 . 0) 

IF  ( ZSTAR1 . GT . ZSTAR)  GO  TO  100 
ZSTAR. ( ZSTAR+ZSTAR1 ) / 2 . 0 
I TRY-2 
GO  TO  110 
180  TEMP ( J ) -TEMP J 
190  CONTINUE 

*  IF  DEF.B64 

TEMP ( J ) - AMAX1 ( TEMP ( J ) , 300 . 0 ) 

‘ENDIF 

*  IF  DEF.B32 

TEMP ( J ) -DMAX1 ( TEMP ( J ) , 3 . D2 ) 

‘ENDIF 

TEMPO ( J ) -TEMP ( J ) 

ZFM ( J ) - ZFM ( J ) *  FLOAT ( N ATOM (M) ) 

IF  (TEMP(J) .GT. 1 .2E4. AND. J.GT. JHAT)  JHAT-J 
IF  (TEMP(J) .GE. 301 .0. AND. J.GT. JSTAR)  JSTAR-J 
IF  (J.LE.J1)  GO  TO  200 
IF  (TEMP(J) .LT.301 .0)  ITER(J)-0 
IF  (TEMP(J) .LT.301 .0)  GO  TO  210 
200  CONTINUE 
210  KPRIN-0 

IF  ( ( JTRY . EQ . 2 ) .OR . ( JpRIN . EQ . 1 . AND . N/NPRIN*NPRIN . EQ . N) )  KPRIN-1 

FIND  NEW  IONIZATION  IN  THE  MESHES  AND  NEW  ENERGY  FLUXES  AT  THE 
BOUNDARIES  IF  ITER(J)  NOT  EQUAL  TO  ZERO. 


ICHCX-1 

220  CALL  FLOION 


NOW  DETERMINE  AMOUNT  BY  WHICH  TEMPERATURE  GUESSES  ARE  INCORRECT. 
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C 

JCOUNT-1 

J1 -MAXO ( JSTAR , JHAT ) 

CALL  PT 

NCOUNT-NCOUNT+1 

C 

IF  (NCOUNT.LT . 100+J1 .OR . JCOUNT . EQ . J1 )  GO  TO  290 
WRITE  (6,550)  NCOUNT , N , DTNH 
DO  230  J-2.J1 

IF  (ITER( J) .NE.O)  WRITE  (6,560)  J 
230  CONTINUE 

GO  TO  (240,280),  JTRY 
CALL  GOTOER 
240  F(l)-FO(l) 

X( 1 )-X( 1 )-U(l )*DTNH 
M-l 
MS-1 

DO  270  J-2.J1 
TEMP(J)-TXEEP(J) 

X(J)«X( J)-U(J)*DTNH 
IF  (TSPALL(J).NE. 1.234)  GO  TO  250 
XS(MS)-XS(MS)-US(MS)*DTNH 
MS-MS+1 
250  CONTINUE 

V(J)-V(J)-DV(J) 

DV  (  J  )  -0 . 0 

P( J)-P( J)-Q( J)-QO( J) 

S( J)-P( J)-SD(J) 

Q(J)-QO(J) 

SET  SPALL  FLAGS  FOR  ACTIVE  ZONES  FOR  JTRY  -  1.  USE  SAME  RULES  AS 
FOR  JTRY  -  2 

IF  (J.GT. JBND(M))  M-M+l 
IF  (TSPALL(J).EQ. 1.234)  GO  TO  270 
IF  (TSPALL(J) .EQ.8. )  GO  TO  270 
IF  (TSPALL(J) .EQ.7. )  GO  TO  260 
IF  (E(J).LT.EM(M))  GO  TO  270 
TSPALL( J)-7. 

260  CONTINUE 

IF  (E( J) .LT . EQSTE(M) )  GO  TO  270 
TSPALL( J)-8 . 

270  F(J)-FO(J) 

DTN-DTN-0.2*DTNH 
DTNH-0 . 8  *  DTNH 
JTRY -2 
RETURN 

280  KCOUNT - KCOUNT + 1 

IF  (KCOUNT.LT. 10)  GO  TO  310 
WRITE  (6,540) 
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CALL  EDIT 
STOP  1 

CHECK  TO  SEE  IF  ALL  MESHES  HAVE  CONVERGED  TO  A  SATISFACTORY 
NEW  TEMPERATURE.  IF  NOT,  CALL  FLOION. 

290  IF  ( JCOUNT . EQ . J1 )  GO  TO  310 
DO  300  J-2.J1 

IF  (ITER(J) .EQ.O.OR.ITERC J+l) .EQ.O)  GO  TO  300 
IF  ( ABS(TEMPO( J+l ) -TEMPO ( J ) ) .LT . 1 . E2 )  GO  TO  300 
IF  (TEMPO( J ) - GT . TEMPO ( J+l ) . AND . TEMP( J ) . GT . TEMP( J+l ) )  GO  TO  300 
IF  (T£MPO( J) . LT . TEMPO ( J+l ) . AND . TEMP( J) .LT . TEMP (J+l ) )  GO  TO  300 
TEMP(J)«(TEMP(J)*ZM(J)+TEMP(  J+l ) ‘ZM( J+l ) ) / ( ZM( J)+ZM( J+l ) ) 

TEMPC J+l )*T£MP( J ) 

300  CONTINUE 

IF  (JCOUNT.LT. Jl)  GO  TO  220 
310  JTRY-1 

IF  (Jl.EQ.JFIN)  GO  TO  330 

ADD  ENERGY  TO  ZONES  WHICH  ARE  NOT  YET  ACTIVE 
J2-J1+1 

DO  320  J-J2.JFIN 

IF  (J-l .EQ. JBND(M))  M-M+l 

E( J)-E( J )+EADD( J)+(F( J)-F( J-l ) )/ZM( J) *DTNH 
TEMP( J)»E( J ) *XMW(M) / FLOAT (NATOM(M) )/2 . 50E8 
IF  (EADD(J) .EQ.O.O)  TEMP ( J ) ■ 300 . 0 
EADD( J)-0.0 

P( J)«2.493E8*EQSTG(M)/XMW(M)/V( J)»(TEMP( J)-300. ) 

IF  (P( J) .LT.0.0)  P(J)-0.0 
S( J)-P( J)-SD(J) 

IF  DEF.B64 

PSMAXC J )»AMAX1 (PSMAX( J) , S( J) ) 

PSMIN( J)«AMIN1 ( PSMIN( J) , S(  J) ) 

ENDIF 

IF  DEF.B32 

PSMAX ( J ) -DMAX 1 ( PSMAX ( J) , S( J) ) 

PSMIN( J)«DMIN1 (PSMIN( J ) , S(  J) ) 

ENDIF 

320  CONTINUE 

CALL  FLOION  ONE  MORE  TIME  TO  CALCULATE  ENERGY  DEPOSITION  RATES  IN 
THE  ZONES  FOR  THE  NEXT  CYCLE 

330  ICHCK-0 

IF  ( TIME . GT . SSTOPM )  GO  TO  340 
IF  ( N / NDEP * NDEP . EQ . N )  CALL  FLOION 
340  ICHCX-1 

STORE  VALUES  OF  NEWLY  FOUND  VARIABLES,  FIND  SMAX  AND  JSMAX, 
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CALCULATE  SHOCK  SPEEDS  IN  THE  MESHES,  FIND  ZONE  WHICH 
CONTROLS  NEXT  TIME  STEP  AND  SK2M  IN  THAT  ZONE. 

FIND  LARGEST  STABLE  ENERGY  TRANSFER  TIME,  DTRC,  AND  ZONE  NUMBER 
IN  WHICH  THIS  OCCURS,  ALSO  FIND  SMALLEST  TIME  IN  WHICH  SOME  ZONE 
ENERGY  WILL  BE  ALTERED  BY  20  PERCENT  DUE  TO  ENERGY  TRANSFER  ONLY 
THIS  TIME  IS  CALLED  DTPRIM 

DTRC* 1 . 0 
DTRC1-0.0 
JTR-0 
S MAX-0 . 0 
SK2M-0.0 
DTPRIM-10 
M-l 
MS-I 

DO  530  J-2.J1 
IF  ( J-l . EQ . JBND(M) )  M-M+l 
ZFM( J)-ZFM(J)/FLOAT(NATOM(M)) 

IF  (ITERC J) .NE.O)  TEMP C  J  ) -TKEEP ( J ) 

IF  ( ITERC J). NE.O)  GO  TO  350 
PCJ)-PN(J) 

ECJ)-ET(J) 

350  SCJ)-PCJ)-SD(J) 

SET  SPALL  FLAGS  FOR  MELT  AND  VAPORIZATION  UNLESS  MATERIAL 
HAS  ALREADY  BEEN  SPALLED. 

IF  (TSPALL(J) .EQ. 1 .234)  GO  TO  370 
IF  (TSPALL(J) .EQ.7. )  GO  TO  360 
IF  (TSPALL(J) .EQ.8 . )  GO  TO  370 
IF  (E(J).LT.EM(M))  GO  TO  370 
TSPALLC  J ) -7 . 

360  CONTINUE 

IF  (E(J) .LT.EQSTE(M))  GO  TO  370 
TSPALLC J) -8. 

370  CONTINUE 

IF  C TSPALLC J) -EQ. 1 .234)  MS-MS+1 

*  IF  DEF.B64 

PSMAXC  J ) -AMAX1 C  PSMAXC  J) , SC  J) ) 

PSMINC  J ) -AMIN1 C  PSMINC  J ) , SC  J) ) 

*  END  I F 

*  IF  DEF.B32 

PSMAXC J)«DMAX1C PSMAXC J) , SC J)) 

PSMINCJ)-DMIN1CPSMINCJ) ,SCJ)) 

*  ENDIF 

IF  CABSCSC J)) .LT.ABSCSMAX))  GO  TO  380 
SMAX-SC J) 

JSMAX-J 

380  V1«RH0CM)‘VC J) 

ENU-1 . /VI 
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EMU-1. /Vl-1. 

IF  (EMU.LT.O.)  GO  TO  410 
MATERIAL  IS  COMPRESSED. 

DXZ-0 . 3325* ( 3 . *EQSTG(M)+ZFM( J ) ) / (2 . +ZFM( J ) ) /RHO(M) 

XZ-1 . -DXZ*RH0(M) *  C 1 . -ENU) 

XZ2-XZ*  *2 

DXY2-2. *DXZ*RHO(M)*(E( J)-EI(J)) 

XY2-DXY2/V(J) 

IF  (CUSPA(M).LE.O.)  GO  TO  390 
ARG-EMU-CUSPA(M) 

IF  (ARG.LE.O.)  GO  TO  390 

XY1-CUSP1(M)+CUSPC(M)*ARG+CUSPD(M)*ARG**2+CUSPS(M)*ARG**3 
DXYl-CUSPC(M)+2. *CUSPD(M)*ARG+3. *CUSPS(M) * ARG* *2 
GO  TO  400 

390  XY1 - ( ( EQSTS ( M ) * EMU+EQSTD ( M) ) * EMU+EQSTC ( M ) ) * EMU 
DXY 1 - ( 3 . *  EQSTS (  M  )  *  EMU +2 . *  EQSTD ( M ) ) * EMU+EQSTC ( M ) 

400  DPDRO- ( ( XY 1 +XY2 ) *  DXZ-XZ  * ( DXY 1 / RHO ( M ) +DXY2 ) ) / XZ2 
DPDR0--1 . * DPDRO 

DEDT-2 . 50E8/XMW(M) * ( 1 . +ZFM( J)/2 . ) *FLOAT(NATOM(M) ) 

GO  TO  440 

410  ALF-EQSTH(M)+(EQSTG(M)-EQSTH(M))*SQRT(ENU) 

IF  (ABS( ALF-EQSTH(M) ) .GT. 1 .E-3)  GO  TO  420 
Wl-1 .0 
GO  TO  430 

420  W 1 -2 . * ( EQSTGC  M ) -ALF ) / ( ALF-EOSTH( M  )  ) 

Wl-(2 . +W1 )/ ( 1 . +W1 ) 

430  DPDRO-P( J )*V(J)*(1. 0+0.665* ( 1 . 5* ALF*W1+ZFM( J) ) / ( W1+ZFM( J) ) ) 
DEDT-1 . 25E8/XMW(M) * (W1+ZFM( J) ) *FLOAT(NATOM(M) ) 

CALCULATE  SHOCK  SPEEDS  IN  MESHES  AND  THE  QUANTITY  (1.  /  SMALLEST 
REQUIRED  HYDRO  TIME  STEP). 

440  IF  (DPDRO. GT. 0. )  GO  TO  450 
Vl-1. /ENU 

ENU2«EQSTN(M) * ( 1 . -VI ) *V1 
EXPR-0 . 

IF  ( ENU2 . GT . -675 . )  EXPR-EXP( ENU2) 

ESl-EQSTE(M)* ( 1 . -EXPR) 

ES10«FL0AT(NAT0M(M))/XMW(M) 

TREF-ES1 / ( 2 . 5E8  *ES10* ( 1 .  +  . 5  *ZFM( J ) ) ) 

DFDT«(TEMP( J) -TREF ) *ES10 
IF  (DFDT.EQ.O.)  DFDT--1 . 

DPDT*EQSTE(M)/(2 . 5E8*(1 .  +  . 5  *  ZFM( J ) ) ) 

DPDT-DPDT *  EXPR*  EQSTN( M ) 

DPDT-DPDT* (2 . *V1 *  *3-Vl * VI ) / RHO ( M ) 

DPDRO -DPDRO+P ( J ) ‘DPDT/DFDT 
IF  ( DPDRO. LE. 0. )  GO  TO  460 
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450  CSCJ)-SQRT(DPDRO) 

460  CONTINUE 

DXZ-X( J)-X(J-l) 

IF  (TSPALLCJ).EQ. 1.234)  DXZ«XS( MS)-X( J-l ) 

IF  (MFLAG(M) .GT.O.AND. J.GT. JB(M))  GO  TO  470 

CALCULATION  OF  MAXIMUM  TIME  STEP  FOR  NONDISPERSIVE  MATERIAL 

SK2M1«CS(J)/DXZ 

IF  (Q(J).GT.O.)  SK2Ml«SK2Ml+( 2 .  *C1 *CS( J)-4 . *C0*C0*DV( J) *ZM( J) /DTNH 
1  )/DXZ 
GO  TO  480 
470  CONTINUE 

CALCULATION  OF  MAXIMUM  TIME  STEP  FOR  DISPERSIVE  MATERIAL 
DU«U(J)-U(J-1) 

IF  (TSPALL(J).EQ. 1.234)  DU-US(MS)-U( J-l ) 

IF  DEF ,  B64 

XX-2.*EQSTACM)*CRH0(M)*CH(M))**2/(0MEGA(M)*CSCJ)*ZMCJ)/VCJ))+2. *C0 
1  *C0* ( ABS( AMIN1 (DU ,0.0)) )/CS( J) 

ENDIF 

XF  DEF  B32 

XX»2. *EQSTA(M)*(RHO(M)*CH(M))**2/(OMEGA(M)*CS( J)*ZM( J)/V( J))+2 . *C0 
1  *CO* ( ABS(DMIN1(DU , 0 .DO) ) ) /CS( J) 

ENDIF 

XXX-1 ,+VAMU(J)/(CS(J)**2/V(J)) 

SK2M1*(CS( J) /DXZ) * (XXX/ ( -XX+SQRT(XX*XX+XXX* ( 1 . +8 . * (RHO(M) *CH(M) / 

1  ( OMEGA(M) *ZM( J) ) )**2)))) 

480  IF  (SK2M-SK2M1)  490,490,500 
490  SK2M-SK2M1 
JTS-J 

500  CONTINUE 

REDUCE  ALLOWABLE  TIME  STEP  IF  NUMBER  OF  ITERATIONS  ON  TEMPERATURES 
IS  GREATER  THAN  (  40+J1 ) 

IF  (NCOUNT.LT. 40+ Jl)  GO  TO  510 
IF  DEF.B64 

SK2M-AMAX1(SK2M, 0.81 /DTNH) 

ENDIF  • 

IF  DEF.B32 

SK2M-DMAX1 ( SK2M , 0 . 8 1 /DTNH ) 

ENDIF 

JTS-0 

510  CONTINUE 

CALCULATE  THE  MINIMUM  TIME  OVER  ALL  MESHES  IN  WHICH  THE  ENERGY 
WILL  HAVE  BEEN  ALTERED  BY  ONE  PERCENT  DUE  TO  ENERGY 
TRANST ER  ALONE. 
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C 

IF  (IDIF.NE.O. AND. ICON. NE.O)  GO  TO  520 
IF  (F(J).EQ.F(J-l))  GO  TO  520 
DTPR1«ABS( .01*E(J)*ZM(J)/(F(J)-F(J-1))) 

IF  (DTPR1 .GT.DTPRIM)  GO  TO  520 

DTPRIM-DTPR1 

JTR-J 

520  ZFM(J)«ZFM( J) ‘FLOAT (N ATOM (M) ) 

EADD(J)-0.0 
530  CONTINUE 

CALCULATE  THE  TOTAL  ENERGY  RERADIATED  FROM  THE  FRONT  AND  REAR 
SURFACES  OF  THE  MATERIAL  UP  TO  THE  CURRENT  TIME 

RERAD-RERAD+(F( 1 )-F( JFIN) )/4 . 186E7*DTNH 
RETURN 
C 

540  FORMAT  (83H0*****  PROBLEM  SHUT-DOWN  BECAUSE  OF  REPEATED  NON-CONVER 
1GENCE  OF  TEMPERATURES  *****  ) 

550  FORMAT  (57H  ITERATION  FOR  NEW  TEMPERATURES  DISCONTINUED  AT  NCOUNT 
1-  , 110 , 3X.9H  CYCLE  -  , 110 , 3X.6HDTNH  -.E10.3) 

560  FORMAT  (10H  J  EQUALS  . 110 , 5X . 17HHAS  NOT  CONVERGED) 

END 
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‘DECK  F INDR 2 

SUBROUTINE  FINDRZ  (DX, DT , N ,RZ1 ) 
‘IF  DEF.B32 

IMPLICIT  DOUBLEPRECISIONC A-H.O-Z) 

‘ENDIF 


FINDRZ  CALCULATES  THE  COMMON  RATIO  OF  A  GEOMETRIC  PROGRESSION  OF 
FINDRZ  CALCULATES  THE  COMMON  RATIO  OF  A  GEOMETRIC  PROGRESSION  OF 
N  TERMS,  WITH  AN  INITIAL  CELL  SIZE  OF  DX  AND  A  TOTAL  SIZE  OF  DT. 


S-l. 

RZ1-0. 

DR-1. 

10  CONTINUE 

RZ1-RZ1+S*DR 
IF  (RZ1.EQ.1.)  GO  TO  20 
Dl-DX* (RZ1 *  *N-1 . )/ (RZ1-1 . ) 

GO  TO  30 
20  CONTINUE 
D1-N*DX 
30  CONTINUE 

IF  CS.GT.O. .AND.D1.LT. DT)  GO  TO  10 
IF  CS.LT.O. .AND.D1.GT.DT)  GO  TO  10 
S--S 

DR-.5*DR 
D2-CDT-D1 )/DT 

IF  (ABS(D2) .GT.l .E-6)  GO  TO  10 
RETURN 

“  THIS  PROGRAM  VALID  ON  FTN4  AND  FTN5  ** 
END 
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•DECK  FLO I ON 

SUBROUTINE  FLO ION 
•IF  DEF.B32 

IMPLICIT  DOUBLEPR£CISION( A-H.O-Z) 

•ENDIF 

C 

REAL  LGDEL 
C 

•CALL  BLANK 
•CALL  AA 
•CALL  AB 
•CALL  AC 
•CALL  EQFL 
•CALL  INDX 

C  THIS  ROUTINE  CALCULATES  THE  DEGREE  OF  IONIZATION  IN  THE  MESHES 
C  AND  THE  ENERGY  FLOW  ACROSS  MESH  BOUNDARIES  WHEN  GIVEN 

C  MESH  VOLUMES  AND  TEMPERATURES. 

C 

ICHCK1-ICHCK+1 
M-l 

NKEEP-N 

DO  10  J-2.JFIN 
10  XFX( J)«0 . 0 

CALCULATE  THE  IONIZATION  OF  EACH  ELEMENT  OCCURING  IN  EACH  MESH 

DO  130  J-2.JFIN 
IF  (J-l .EQ. JBND(M))  M-M+l 
NEM-NELEM(M) 

IF  (J-JHAT)  30.30.20 
20  CONTINUE 

GO  TO  (120.130).  ICHCX1 
CALL  GOTOER 

30  IF  ( ITER( J) . EQ . 0 . AND . ICHCK . EQ . 1 )  GO  TO  130 
IF  (TEMP(J)-l .2E4)  40,40,50 
40  IF  ( El ( J ) . GT . 1 . E-20 )  GO  TO  50 
GO  TO  (120,130),  ICHCK1 
CALL  GOTOER 
50  CALL  SAHA 

IONIZATION  LEVELS  OF  ALL  ELEMENTS  ARE  CHOSEN  PROPERLY  -  THE 
ENERGY  USED  IN  CAUSING  IONIZATION  IN  MESH  J  IS  CALCULATED  AND 
THE  IONIZATION  LEVEL  IN  EACH  ELEMENT  AND  THE  LEVEL  FOR  THE 
MATERIAL  ARE  ST0..ED 

EI(J)«0.0 
DO  70  Nl-1 , NEM 
N-IELEM(M.Nl) 

KN-KMAX(N) 
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DO  60  K-l.KN 
L-NI(K.N) 

IF  (L.LE.O)  GO  TO  60 

EI( J )-EI ( J)+R(K,N) *EN( N ,L) * AF(M , N) *FLOAT( NATOM(M) ) *9 . 632E1 1 /XMW( M) 
IF  (J.NE.JTS)  GO  TO  60 

IF  ( KPRIN . EQ . 1 )  WRITE  (6,190)  KATL(M) ,NAMEL(N) , KN ,L , J , El ( J) , R( X . N) 
1  ,  EN  (  N ,  L  )  ,  AF  (  M ,  N  ) 

60  CONTINUE 
70  ZF(N, J)-ZFl(N) 

ZFM ( J ) - ZSTAR 

IF  ( MCOUNT . GT . 500 )  GO  TO  80 

IF  ( ABS( ZSTAR- ZSTAR1 ) .GT.O. 01 *ZSTAR1. AND. ZSTAR. GE.l.E-40)  GO  TO  80 

IF  (ICHCK.EQ.O)  GO  TO  110 
IF  (KPRIN. EQ.O)  GO  TO  130 
IF  (J.NE.JTS)  GO  TO  130 
80  WRITE  (6,200) 

DO  90  Nl-l.NEM 
N-IELEM(M.Nl) 

IF  (IPLUSO(N)+IPLUS(N). EQ.O. AND. IPLUS(N).NE.O)  WRITE  (6,270)  N 
90  CONTINUE 

WRITE  (6.210)  J, MCOUNT. NKEEP, I CHCX, TEMP ( J) ,ZFM(J) 

DO  100  Nl-l.NEM 
N-IELEM(M.Nl) 

KN-KMAX(N) 

100  WRITE  (6.220)  NAMEL(N) , ZF1(N) 

WRITE  (6,230)  (NI(K.N) ,K-1 ,KN) 

WRITE  (6.240)  (R(K,N) ,K-1 .KN) 

IF  (ICHCK.EQ.O)  GO  TO  110 
GO  TO  130 
110  CALL  OP AGUE 
GO  TO  130 
120  CALL  OPAGC 
130  CONTINUE 

IF  (ICHCK)  140,150,140 

CALCULATE  ENERGY  TRANSMISSION  ACROSS  MESH  BOUNDARIES 

IF  I FLOW  EQUALS  0  NO  HEAT  TRANSFER  RATES  ARE  BEING  CALCULATED 
THIS  CYCLE. 

IF  ITER(J)  -  0  NO  ENERGY  TRANSMISSION  AT  ZONE  BOUNDARY  IS 
CALCULATED  THIS  CYCLE. 

IF  ITER(J)  -  1  TRANSMISSION  AT  BOUNDARY  DUE  TO  DIFFUSION  ONLY 
IS  CALCULATED. 

IF  ITER(J)  -  2  TRANSMISSION  AT  BOUNDARY  DUE  TO  CONDUCTION  ONLY 
IS  CALCULATED 

IF  ITER(J)  -  3  TRANSMISSION  AT  BOUNDARY  DUE  TO  DIFFUSION  AND 
CONDUCTION  IS  CALCULATED. 

IF  ITER(J)  EQUALS  4  THEN  IFLOW  EQUALS  ZERO  ALSO 
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140  I?  (IFLOW.EQ.O)  GO  TO  180 
CALL  TRANS P 

IF  (Jl.EQ.JFIN)  GO  TO  180 
XLAMl(Jl+l)-0.0 
XLAM2(  Jl+D-0.0 
GO  TO  180 

150  IF  ( NKEEP /NPRIN  * NPRIN . NE . NKEEP )  GO  TO  180 
NKEAP-NXEEP+1 
DO  170  NS-l.NSPEC 
IF  (SS(2,NS))  170.170,160 
160  WRITE  (6,250)  NXEAP.NS 

WRITE  (6.260)  (SS( J ,NS ) , J-l , JFIN) 

170  CONTINUE 

IF  (IFLOW.EO.O)  GO  TO  180 
WRITE  (6,280) 

WRITE  (6,260)  (F( J) , J-l , JFIN) 

C  WRITE  (6,200) 

C  WRITE  (6,270)  (XFX( J) , J-l , JFIN) 

180  N-NKEEP 
RETURN 
C 

190  FORMAT  (7HOFLOION , 2( IX . A10) , 5H  KN  -,I3,4H  L  -,I3,4H  J  -,I3,8H  EI(J 
1)  -.1PE10.3.9H  R(K,N)  - . 1PE10 . 3 , 10H  EN(N , L)  - . 1PE10 . 3/ 10X . 10H  AF(M 
2 ,N)  ■ , 1PE10 . 3/ ) 

200  FORMAT  (//) 

210  FORMAT  (30H  CALCULATED.  FLOION  SUBROUTINE/ 1 OX, 4HJ  -  ,15,1 OX , 9HMC0U 
1NT  -  , I 5 , 1 OX , 8HCTCLE  -  , 15 , 10X , 7HICHCX  - , I5/10X . 1 3HTEMPERATURE  - 
2  , E10 . 3 , 10X , 12HIONIZATION  -.E10.3/) 

220  FORMAT  ( 15H0 IONIZATION  IN  .A10.2H-  ,E10-3) 

230  FORMAT  (23H0 IONIZATION  LEVELS  ARE  , 110 ,7( 1H , , 110) ) 

240  FORMAT  ( 28HOFRACTIONAL  POPULATIONS  ARE  , E10 . 3 , 7( 1H , , E10 . 3) ) 

250  FORMAT  (//26H  DEPOSITION  EDIT  FOR  CYCLE , I 1 0 , 2X , 1 OHAND  SOURCE, 110/2 
1  7H  UNITS  ARE  ERGS / GRAM / S ECOND / ) 

26C  FORMAT  (1P10E12.4) 

27C  FORMAT  (56H  THERE  IS  AN  UNCONTROLLED  JUMP  IN  IONIZATION  IN  ELEMENT 
1  ,12) 

280  FORMAT  (//57H  FLUXES  INTO  THE  MESHES  IN  UNITS  OF  ERGS,  SQUARE  CM/SE 
1C0ND) 

END 
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•DECK  GENRAT 

SUBROUTINE  GENRAT 
•IF  DEF.B32 

IMPLICIT  DOUBLEPRECIS ION (A-H.O-Z) 

•ENDIF 
C 

C  * _ * _ * _ * _ 

c 

C  IMPORTANT  VARIABLES  LOCAL  TO  THIS  SUBROUTINE 

C 

C  CALPA  CALORIES  ABSORB! 

C  DX  USED  AS  FIRST  ZC 

C  EITOT  THE  TOTAL  SOURC1 

C  INCIDENCE  COMPU1 

C  EPG  ERG/ GRAM  ABSORB] 

C  EPREV  USED  IN  CALCULA1 

C  AND  IONIZATION  ! 

C  OF  THE  PREVIOUS 

C  ERGPA  ERGS  ABSORBED  12 

C  EOI  THE  ENERGY  OF  A 

C  NRZC  ZONE  CONTROL.  IF  P( 

C  REGIONS  FOR  WHICH  A 

C  ZONES  WILL  BE  SPECI1 

C  FLAG  TO  INDICATE  THJ 

C  CALCULATED  WITHIN  T1 

C  SCREEN  TEMPORARY  STORAC 

C  CONSTANTS  --  ONI 

C  SUB- SHELL 

C  SUMCAL  TOTAL  CALORIES /( 

C  INCLUDING  THIS  5 

C 

c  * _ * _ * _ * _ * _ i 

c 

•CALL  BLANK 
•CALL  AA 
•CALL  AB 
•CALL  AC 
•CALL  EQVP 
•CALL  PLOTCM 
•CALL  RZCOM 
•CALL  SPLLC 


CALPA 

DX 

EITOT 

EPG 

EPREV 


ERGPA 

EOI 

NRZC 


SCREEN 


SUMCAL 


CALORIES  ABSORBED  IN  ZONE 

USED  AS  FIRST  ZONE  SIZE  IN  INPUT 

THE  TOTAL  SOURCE  STRENGTH ‘COSINE  OF  ANGLE  OF 

INCIDENCE  COMPUTED  FOR  EACH  SPECTRUM. 

ERG/ GRAM  ABSORBED  IN  ZONE 

USED  IN  CALCULATIONS  OF  ENERGY  OF  X-RAY  EDGES 
AND  IONIZATION  POTENTIALS  TO  STORE  THE  ENERGY 
OF  THE  PREVIOUS  NUCLEUS -ELECTRON  CONFIGURATION 
ERGS  ABSORBED  IN  ZONE 

THE  ENERGY  OF  A  NUCLEUS -ELECTRON  CONFIGURATION 
ZONE  CONTROL.  IF  POSITIVE,  NRZC  -  THE  NUMBER  OF 
REGIONS  FOR  WHICH  A  ZONE  SIZE  RATIO  AND  NUMBER  OF 
ZONES  WILL  BE  SPECIFIED.  IF  NEGATIVE,  NRZC  IS  A 
FLAG  TO  INDICATE  THAT  THE  ZONE  SIZES  ARE  TO  BE 
CALCULATED  WITHIN  THE  PROGRAM. 

TEMPORARY  STORAGE  FOR  THE  SLATER  SCREENING 
CONSTA2TTS  —  ONE  FOR  EACH  S+P,  D,  AND  F 
SUB- SHELL 

TOTAL  CALORIES /CM* *2  ABSORBED  UP  TO  AND 
INCLUDING  THIS  ZONE 


BLANK 

AA 

AB 

AC 

EQVP 

PLOTCM 

RZCOM 

SPLLC 

DIMENSION  ASAVEC5),  NSAVE( 15) ,  SCREEN(14) 
REAL  LGDEL 


READ  PROBLEM  DESCRIPTION,  PROBLEM  CONTROL  VARIABLES,  AND 
OUTPUT  CONTROL  VARIABLES. 


READ  (5 , 1740, END-10)  (DISCPT( I ) , 1-1 , 8) 
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10  READ  (5.*. END-20)  NSPEC , NTEDT .NJEDIT , LOZHIZ , ILOG, ILIN , ICON , IDIF 
WRITE  (6,1920) 

WRITE  (6,1740)  (DISCPT(K) ,K-1 , 8 ) 

WRITE  (7,1740)  (DISCPT(K) ,K-1 ,8) 

WRITE  (9,1740)  (DISCPT(K) ,K-1 , 8 ) 

WRITE  (9,2170) 

WRITE  (6,1760) 

WRITE  (6,2040)  ICON, IDIF 
20  IF  (NTEDT)  40,40.30 
C  FORMAT  WAS  8E10 

30  READ  (5, ‘.END-40)  (  TEDIT(  I ) , I-i , NTEDT) 

40  IF  ( NJEDIT)  60,60,50 
C  FORMAT  WAS  8110 

50  READ  (5, ‘.END-60)  (MTLN( I ) ,DSTF( I ) , 1-1 , NJEDIT) 

C  FORMAT  WAS  8110 

60  READ  (5.*, END-70)  NRZC , NMTRLS , JRZL , JZPUL , NPRIN , NTAPE , NREZON , JCYCS 

SET  DEFAULT  VALUES  FOR  JRZL.  JZPUL,  NPRIN.  NTAPE,  NREZON. 

70  IF  (JRZL.EQ.O)  JRZL-25 
IF  (JZPUL. EQ.O)  JZPUL-50 
IF  (NPRIN. EQ.O)  NPRIN-20 
IF  (NTAPE. EQ.O)  NTAPE- 100 

DEFAULT  FOR  NREZON  WILL  INHIBIT  REZONING. 

IF  (NREZON. EQ.O)  NREZON-JCYCS 
NREZON -MAXO ( NREZON , 25 ) 

WRITE  (6.1780)  NRZC. NMTRLS .JRZL, JZPUL, NPRIN, NTAPE, NDEP .LOZHIZ, JF IN 
1  . JCYCS . NREZON 

READ  (5,*, END-80)  RSCRIT ,RZCO ,RZC1 
80  IF  ( RSCRIT. EQ. 0- )  RSCRIT- 1 . /FLOAT( JZPUL) 

IF  (RZCO.EQ.O.)  RZCO-1 . /FLOAT( JRZL) 

WRITE  (6.1790)  RSCRIT ,RZCO , RZC1 
FORMAT  WAS  8E10 

READ  (5,*, END-90)  CXS , TS , ANGLE , DTMIN . DIFTST. NDEP . JPRIN , ION 

READ  MATERIAL  2  ONING  CONSTANTS  AND  INITIAL  HYDRO  TIME  STEP . 

90  IF  (NRZC.LE.O)  GO  TO  140 
NMT - NMTRLS - 1 
IF  (NMT)  110,110,100 
C  FORMAT  WAS  8110 

100  READ  (5, * .END-110)  ( JBND(M) , M-l ,NMT) 

C  FORMAT  WAS  8110 

110  READ  (5, » .END-120)  JFIN, (NZ(L) ,L-1 .NRZC) 

C  FORMAT  WAS  8E10 

120  READ  (5, * .END-130)  DX , TIME ,( RZ(M) , M-l , NRZC) 

130  GO  TO  160 
140  CONTINUE 
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NRZC-0 

READ  (5. * .END-150)  TIME . (RZ( M) , M-l , NMTRLS) 

150  DX-0 
J.60  CONTINUE 

THIS  CHANGE  BY  DLJ  2  JUN  88  TO  ALLOW  FOR  DELAYED  DEBUG  OUTPUT 
IF  JPRIN  -  0.  NO  DEBUG  --  SAME  AS  BEFORE 

IF  DEBUG  WANTED,  INPUT  JPRIN  -  CYCLE  NUMBER  AT  WHICH  THE  DEBUG 
PRINTOUT  IS  TO  START. 

NDBG-JPRIN 

IF  (NDBG.LE.O)  NDBG-JCYCS+1 

IF  C JPRIN. GE.l)  JPRIN- 1 

WRITE  (6,1840)  ANGLE , TIME , CKS , TS , NDEP 

DTN-TIME 

DTNH-TIME 

DX-DX/RZC1) 

READ  NUMBER  OF  ELEMENTS  IN  THIS  PROBLEM  AND  NUMBER  OF  X-RAY 
ABSORPTION  EDGES  TO  BE  INPUT  FOR  EACH. 

FORMAT  WAS  8110 
READ  (5. * .END-170)  NELT 
FORMAT  WAS  8110 

170  READ  (5, * .END-180)  (NOE(N) ,N-1 . NELT) 

READ  IN  DATA  FOR  EACH  ELEMENT  AND  MAKE  NECESSARY  INITIAL 
CALCULATIONS  FOR  EACH 

180  DO  910  N-l.NELT 

FORMAT  WAS  2I10.A10.E10 
READ  (5. 1710, END- 190)  NAMEL(N) 

190  READ  ( 5 END-200 )  NTBL(N) ,NVARE(N) , XAW(N) 

200  IT-NOE(N) 

FORMAT  WAS  8E10 

READ  (5, * .END-210)  (AA(N, I) ,B(N, I) ,EDGE(N, I) , 1-1 , IT) 

210  IF  ( NVARE(N) )  250,250,220 
220  IT-NTBL(N) 

FORMAT  WAS  8E10 

READ  (5, * .END-230)  (XI(N. J) . J-l , IT) 

230  EN(N , 1 )«XI (N , 1 ) 

DO  240  J-2 , IT 

240  EN(N , J)«EN(N, J-l )+XI(N, J) 

NOEC(N)-MINO(NOE(N) , 19) 

GO  TO  910 

ALL  POSSIBLE  EDGES  OF  AN  ELEMENT  MUST  BE  INPUT  FOR  THIS  ROUTINE 
TO  OPERATE  PROPERLY. 

THIS  ROUTINE  CALCULATES  THE  ENERGIES  OF  THE  ABSORPTION  EDGES  OF 
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THE  ELEMENTS  —  EDGECf ELEMENT , EDGE) ,  THE  ENERGY  OF  ALL  POSSIBLE 
IONIZATION  STATES  OF  THE  ELEMENTS  —  ENIK( ELEMENT , ION) ,  THE 
IONIZATION  POTENTIAL  OF  EACH  IONIZATION  STATE  — 

XI ( ELEMENT , ION ) ,  AND  THE  ENERGY  USED  IN  IONIZATION  TO  THIS 
STATE . 

250  ESUM-0. 

IBB-0 

Ki-NTBL(N) 

DO  260  K-1,15 
DO  260  KK-1,14 
EBB(N.K,KK)-0.0 
260  CONTINUE 

DO  890  K2-1.K1 

IF  ( K2 . NE . 1 . AND . ION . EQ . 0 )  GO  TO  550 
DO  270  K-1,14 
270  NSPDF(K)-0 

DO  280  K-1,19 
NSUM(K)-0 
280  NGRUP(K)-0 
NELEC-K1+1-K2 

FIND  THE  NUMBER  OF  ELECTRONS  IN  EACH  SUB-SHELL  FOR  THIS  ION  STATE 
C  WHEN  ION  EQUALS  1 . . . 

IF  (NELEC-78 )  310.310,290 
290  DO  300  K-1,6 
300  NGRUP(K+13)-ITBL(NELEC,K) 

GO  TO  450 

310  IF  (NELEC-69)  340.340,320 

320  DO  330  K-1,6 

330  NGRUP (K+10)-ITBL( NELEC. K) 

GO  TO  470 

340  IF  (NELEC-46)  370,370,350 

350  DO  360  K-1,6 

360  NGRUP ( K+9 ) « I TBL  C  NELEC , K ) 

GO  TO  480 

370  IF  (NELEC-28 )  400,400,380 

380  DO  390  K-1,6 

390  NGRUP (K+6)-ITBL( NELEC, K) 

GO  TO  500 

400  IF  (NELEC-10)  430,430,410 

410  DO  420  K-1,6 

420  NGRUP (K+3)-ITBL( NELEC, K) 

GO  TO  520 
430  DO  440  K-1,6 
440  NGRUP ( K ) » I7BL( NELEC , K ) 

GO  TO  540 
450  DO  460  K-l ,3 
460  NGRUP ( K+ 1 0 ) - I LTBL5 ( K ) 

470  NGRUP( 10)-ILTBL4(  1  ) 
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480  DO  490  K-l .3 

490  NGRUP ( K+6 ) - ILTBL3 (  K  ) 

500  DO  510  K-l. 3 

510  NGRUP  ( K+3-).-  ILTBL2  (  K  ) 

520  DO  530  gbl,3 
530  NGRUP(K)-ILTBL1(K) 

540  CONTINUE 
GO  TO  580 

CALCULATE  THE  NUMBER  OF  ELECTRONS  IN  EACH  SUB -SHELL  FOR  THIS  ION 
STATE  WHEN  ION  EQUALS  0  . . . 

550  NELEC-K1 + 1 -K2 
DO  560  K-l , 19 

IF  (NGRUP (20-K))  560,560,570 
560  CONTINUE 

570  NGRUPC  20-K ) -NGRUP ( 20-K ) - 1 

CALCULATE  THE  NUMBER  OF  ELECTRONS  IN  EACH  OF  THE  SUB-SHELL 
GROUPS  NEEDED  IN  SCREENING  CONSTANT  CALCULATIONS  — 

580  NSPDF(l) -NGRUPC 1) 

NSPDFC 2 ) -NGRUP ( 2 ) +NGRUP ( 3 ) 

NSPDF ( 3 ) -NGRUP ( 4 ) +NGRUP ( 5 ) 

NSPDF(4)-NGRUP(6) 

NS PDF ( 5 ) -NGRUP ( 7 ) +NGRUP ( 8 ) 

NSPDF (6) -NGRUP( 9) 

NSPDF(7)-NGRUP( 10) 

NSPDF ( 8 ) -NGRUP (11) +NGRUP (12) 

NSPDF(9) -NGRUPC 13) 

NSPDFC 10) -NGRUPC 14) 

NSPDF (11) -NGRUP ( 15 )+NGRUP( 16) 

NSPDFC 12) -NGRUPC 17) 

NSPDF (13) -NGRUP (18) 

NSPDFC 14) -NGRUPC 19) 

CALCULATE  THE  TOTAL  NUMBER  OF  ELECTRONS  UP  TO  AND  INCLUDING 
THOSE  IN  EACH  SUB -SHELL. . . 

NSUM1-0 

DO  590  K-l , 19 

NSUM1 -NSUMl+NGRUPC  K) 

590  NSUM( K ) -NSUM1 

FIND  THE  NUMBER  OF  SUB-SHELLS  ASSOCIATED  WITH  THIS  ATOM  (K2-1) 
OR  ION  (K2  GREATER  THAN  1)  —  IN  CASE  OF  THE  ATOM  STORE  THIS 
NUMBER  AS  NOEC(N)  (NUMBER  OF  EDGES  CALCULATED),  ALSO  STORE  THE 
NUMBER  OF  ELECTRONS  IN  EACH  SUB-SHELL  AS  NION,  FOR  LATER  USE  -- 
FOR  BOTH  ATOM  AND  ION  FIND  THE  NUMBER  OF  COMPACTED  SUB-SHELLS 
AND  CALL  IT  K3 . 

IFLAG-1 
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DO  600  K-l , 19 

IF  (NELEC-NSUM(K))  610,610.600 
600  CONTINUE 

610  IF  (NGRUP(K) .NE. 1)  GO  TO  620 

IF  ( K . NE . 2 . AND . X . NE . 4 . AND . X . NE . 7 . AND . X . NE .11. AND . X . NE .15. AND . K . NE . 
1  19)  GO  TO  620 
1 FLAG* 2 
IBB-IBB+1 
NSAVE( IBB ) -X2 
NLEC(N,IBB)*X-1 
620  IF  (K2-1)  630,630,650 
630  NOEC(N)*X 

XN«NOEC(N)+l 
DO  640  KX-1 , K 
IJX-XN-XX 

640  NION(N,IJX)-NGRUP(KX) 

WRITE  (6,1680)  (NION(N , X'O  , XX-1 , 19) 

XN-ITABL(KN-l) 

650  X3-ITABL(X) 

X31-X3+1 

IF  (X2.GT.1)  X31-1 

IF  ( I  FLAG .  EQ .  2  .  AJg) .  K2  .  NE  .  1 )  X31-X3 

FIND  THE  SCREENING  CONSTANTS  FOR  THE  SUB-SHELLS  OF  THIS  ATOM  OR 
ION  WITH  NO  ABSORPTION  EDGE  ELECTRONS  REMOVED  —  USE  THESE 
CONSTANTS  TO  CALCULATE  THE  ENERGY  ASSOCIATED  WITH  THIS  STATE 
OF  THE  ELEMENT  —  STORE  AS  EION( ELEMENT , IONIZATION) .  ALSO, 

FIND  THE  SCREENING  CONSTANTS  FOR  THE  ATOM  STATE  OF  THIS  ELEMENT 
WHEN  AN  ABSORPTION  EDGE  ELECTRON  HAS  BEEN  REMOVED  —  USE 
THESE  TO  FIND  THE  ENERGY  OF  THIS  ATOM  AND  THUS  THE  ENERGIES 
OF  THE  ABSORPTION  EDGES. 

DO  850  NG-1.K31 
IF  (NG-1)  670,670,660 
660  NSTMP-NSPDF(NG-1)-1 

NS PDF ( NG- 1 ) -MAXO ( NSTMP , 0 ) 

NG-1  IS  THE  SUB-SHELL  ASSOCIATED  WITH  THIS  ABSORPTION  EDGS . 

CALCULATE  THE  SCREENING  CONSTANTS 

670  NPREVT=NSPDF( 1 )-NSPDF(2) 

IF  (K3.GE.5)  GO  TO  680 
GO  TO  (720,710,700,690),  K3 
CALL  GOTOER 

680  NPREVS-NSPDF(3)*NSPDF(4) 

SCREEN ( 5 ) -FLOAT ( K1 -NPREVT ) -0 . 8  5  *  FL0AT( NPREVS ) -0 . 35  *  FLOAT (MAXO 
1  ( NSPDF( 5 )- 1 , 0 ) ) 

690  SCREEN ( 4 ) - FLOAT ( XI -NPREVT-NSPDF( 3) ) -0 . 35  *  FLOAT ( MAX0( NSPDF( 4 ) - 1 . 0 ) ) 
700  SCREEN ( 3 ) -FLOAT( K1 -NSPDF( 1 ) ) -0 . 85  *  FLOAT ( NSPDF( 2 ) ) -0 . 35  * FLOAT( MAXO 


A-59 


ooooo  o o o n o  noon 


HYPUF  SOURCE  LISTING 


1  (NSPDF(3)-1 ,0) ) 

710  SCREENC  2 )-FL0ATC XI )-0 . 85 *FLOAT(NSPDF( 1 ) )-0 . 35 ‘FLOATCMAXOC  NSPDFC 2  )- 
1  1.0)) 

720  SCREEN ( 1 ) -FLOAT C  XI ) -0 . 3  *  FLOAT ( MAXO ( NS PDF ( 1 ) - 1 , 0 ) ) 

IF  (X3.LE.5)  GO  TO  750 
NPREVT -NPRE VT +NPREV S 
NPREVS-NSPDF(  5 ) 

KK-5 

730  DO  740  X4-1.2 
X5-XX+X4 

SCREENC  K5 ) -FLOAT( Ki -NPREVT -NPREVS ) -0 . 35  *  FLOAT ( MAXO  C  NS PDF ( K5 ) - 1 , 0  )  ) 
NPREVS -NPREVS +NSPDFC X5 ) 

IF  (K3.LE.K5)  GO  TO  750 
740  CONTINUE 
KK-KX+3 

SCREENC  XX) -FLOAT ( XI -NPREVT ) -0 . 85  *  FLOAT ( NPREVS ) -0 . 35  *  FLOATC  MAXO 
1  (NSPDF(KK)-l , 0) ) 

NPREVT-NPREVT+NPREVS 
NPREVS -NS  PDF ( XX ) 

IF  (XK.LT.X3)  GO  TO  730 

CALCULATE  THE  ENERGY  OF  THIS  ATOM  OR  NUCLEUS -ELECTRON 
CONFIGURATION. 

750  E0I-0.0 

DO  760  K-1.K3 

760  EO I -E0 1+ SCREEN CK) * *2*FLOAT(NSPDFCK) ) /XNSTARCX) 

EOI-13 . 56*E0I 
IF  CNG.GT.l)  GO  TO  790 
IF  CK2.EQ.1)  GO  TO  770 

CALCULATE  AND  STORE  THE  VALUES  OF  THE  IONIZATION  POTENTIALS  — 

XI C ELEMENT , IONIZATION )  —  AND  THE  ENERGY  USED  IN  IONIZATION  -- 
ENC ELEMENT. IONIZATION)  —  AT  THIS  ION  STATE. 

XI ( N , K2- 1 )-EPREV-EOI 
ESUM-ESUM+XI C  N . K2- 1 ) 

ENCN.K2-D-ESUM 
EIONC  N , K2-1 )-EOI *  1 . OE-3 
770  EPREV-EOI 

IF  CK2.GT.1)  GO  TO  850 
DO  780  K-l . K3 
K4-K3+1-K 

780  SCREN0CN.K4) -SCREENC X) 

GO  TO  850 

CALCULATE  THE  ENERGIES  OF  THE  ABSORPTION  EDGES  AND  STORE  THEM 
AS  EDGECC ELEMENT, EDGE)  AND  STORE  THE  VALUES  OF  THE  SCREENING 
CONSTANTS  AND  ELECTRON  NUMBERS  OF  THESE  SUB-SHELLS  OF  THE 
ATOM  FOR  LATER  USE . . . 
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790  IF  (K2.NE.1)  GO  TO  800 

EDGEC( N , NG-1 )■( EPREV-EOI ) *  1 . E-3 
800  IF  (IFLAG.EQ.1.0R.NG.GT.K3)  GO  TO  840 
KTMP-1 

NTMP -NLEC ( N , I BB ) + 1 

IF  (NTMP.EQ.19.OR.NTMP.EQ.15.OR.NTMP.E0.il)  KTMP-4 
IF  (NTMP.EQ.7)  KTMP-3 
IF  (NTMP.EQ.4)  KTMP-2 
LTMP-K3 

LLBND-K3+1-KTMP 

LUBND-K3-1 

IF  (LLBND.EQ.K3)  GO  TO  820 
DO  810  K-LLBND.LUBND 
810  SCREEN(K3)*SCR£EN(K3)-0 . 15*NSPDF(K) 

820  EBBTMP-0.0 

DO  830  K-1.K3 

830  EBBTMP -EBBTMP +SCREEN (  K  )  *  *  2  *  FLOAT ( NS  PDF ( K ) ) / XNSTAR ( K ) 

K4-KN+2-NG 

EBB( N , IBB ,K4)»1 . 356E-2*EBBTMP 
840  NSPDF ( NG- 1 ) »NSTMP+ 1 
850  CONTINUE 

IF  (K2-1)  860 , 860 , 890 

REARRANGE  THE  NUMBERING  OF  THE  EDGES  SO  THAT  THE  K  EDGE 
OCCURS  AS  THE  LARGEST  NUMBERED  OF  THE  EDGES  AND  THE  S+P 
SUB-SHELL  EDGES  ARE  ASSIGNED  DOUBLY  TO  BOTH  S  AND  P  SUB-SHELL 
GROUPS . 

860  K4-N0ECCN) 

KL-ITABLCK4) 

DO  870  K-l . KL 
870  SCREENCK)-EDGEC(N.K) 

KL-K4+1 

DO  880  K*1 , K4 

KK-ITABL(K) 

IJK-KL-K 

880  EDGECCN, I JK)« SCREEN (KK) 

890  CONTINUE 

CALCULATE  AND  STORE  THE  LAST  XI,  EN ,  AND  EION... 

XICN.K1 )«EPREV 
EN(N.K1)«EPREV 

IF  (K1.GE.2)  EN(N , K1 ) «EN(N ,K1)+EN(N,K1-1) 

EION(N,K1)-0. 

IF  (JPRIN.GT.O)  WRITE  (6,1690)  N , ( EION(N , K) ,K-1 , 20) 

CALCULATE  AND  STORE  THE  VALUES  OF  BOUND-BOUND  TRANSITION  ENERGIES 
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DO  900  K-1,15 
DO  900  KX-1,14 

IF  (EBB(N.K.KK).EQ.O)  GO  TO  900 
Nl-NSAVECK) 

EBB(N,K.KK)-EI0N(N,N1)-EBB(N,K,KK) 

900  CONTINUE 

910  CONTINUE 

READ  IN  DATA  FOR  EACH  MATERIAL 

DO  1030  M-l.NMTRLS 

FORMAT  WAS  A10.2I10 

READ  (5, 1710. END-920)  MATL(M) 

920  READ  (5. * .END-930)  NVARM(M) , NATOM(M) 

FORMAT  WAS  8E10 

930  READ  ( 5 , * , END— 940 )  RHO(M) , EQSTC(M) , EQSTD(M) , EQSTE(M) ,EQSTG(M) 

1  . EQSTH(M) , EQSTS(M) , PMIN(M) , ISPLLM(M) ,EM(M) 

940  IF  (EMCM) .LE.1.E7)  EM(M)-4 . 186E?*EM(M) 

EM  IS  THE  MELT  ENERGY  OF  THE  MATERIAL  (ERGS/GM) 

ISPLLM  IS  A  FLAG  TO  INDICATE  WHICH  MODEL  PMIN  AND  TSPALL  ARE 
BASED  ON . 

FORMAT  WAS  8E10 

READ  (5,*. END-950)  CUSPl(M) ,CUSPA(M) ,CUSPC(M) .CUSPD(M) .CUSPGCM) 

1  , CUSPS(M) 

FORMAT  WAS  8E10 

950  READ  (5,* .END-960)  Y0(M) , AMU(M) ,YADD(M) .YMU(M) .XMW(M) .LGDEL(M) 

1  , XCON(M) 

960  EC  2 ) -7 . 5E10  *  FLOAT ( NAT0M( M ) ) /XMW( M ) 

EM  ( M ) -EM ( M ) +E ( 2 ) 

EQSTE  (  M  )  -EQSTE  (M)-*-E(2) 

EOSTN(M)-EQSTC(M)/EQSTG(M) / C  EQSTE(M) *RHO(M) ) 

READ  IN  PARAMETERS  FOR  ELASTIC  VISCOPLASTIC  MODEL  AND  POSSIBLY 
FOR  MAXWELL  GEOMETRIC  DISPERSION  MODEL. 

READ  (5, *, END-970)  EQSTA(M) ,0MEGA(M) , PRELAX(M) , SHEARR(M) .TRELAX(M) 
1  ,  MFliAG(M) 

IF  MFLAG  -  1.  READ  IN  PARAMETERS  FOR  MAXWELL  GEOMETRIC 
DISPERSION  MODEL. 

970  AMU2(M)-0 . 

TRELX2 ( M ) -0 . 

IF  ( MFLAGC M ) . EQ . 1 )  READ  (5 END-980)  AMU2(M) , TRELX2(M) 

980  CH(M)-SQRT(EQSTC(M)/RHO(M) ) 

GOKE ( M ) -AMU ( M ) / EQSTC  CM) 
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G0KE2  C  M ) -  AMU2 ( M ) /EQSTC ( M ) 

C  FORMAT  WAS  8110 

READ  ( 5 END-990 )  NELEM(M) 

990  IF  (NELEM(M) -LE.5)  GO  TO  1000 
WRITE  (6,1700)  NELEM(M) ,MATL(M) 

STOP 

1000  CONTINUE 

IT-NELEM(M) 

C  FORMAT  WAS  8110 

READ  (5, *, END-1010)  (IELEM(M.N) ,N-1 , IT) 

C  FORMAT  WAS  8E10 

1010  READ  (5,*, END-1020)  ( ASAVE(N) ,N-1 , IT) 

1020  DO  1030  N-l.IT 
Nl-IELEM(M.N) 

1030  AF(M,N1)-ASAVE(N) 

CALCULATE  ZONING 

1040  CONTINUE 

NRZC  IS  USED  AS  A  FLAG  TO  INDICATE  WHETHER  ZONING  IS  TO  BE 
CALCULATED  BY  EXPLICIT  INSTRUCTIONS  OR  AUTOMATICALLY. 

NRZC  .GT.  0  INDICATES  ZONING  IS  DONE  PER  EXPLICIT  INSTRUCTIONS 
NRZC  ,EQ.  0  INDICATES  THIS  IS  THE  FIRST  GUESS  AT  AUTOMATIC 
ZONING.  -NRZC  .LT.  0  INDICATES  THIS  IS  THE  REVISED  ZONING. 

IF  (NRZC.LE.O)  CALL  AZONE  (DX.NRZC) 

LZ-1 

DO  1050  J-2.JFIN 

IF  ( J.GT.NZ(LZ))  LZ-LZ+1 

DX»DX*RZ(LZ) 

X( J)-X( J-1)+DX 
IF  (NRZC.EQ.O)  GO  TO  1050 
PSMAX( J)-0. 

PSMIN( J)-0. 

1050  CONTINUE 

IF  (NJEDIT.LE.O)  GO  TO  1080 
IF  (NRZC.LE.O)  GO  TO  1080 
1-1 

DO  1070  J-2.JFIN 

IF  (I .GT.NJEDIT)  GO  TO  1080 

M«MTLN( I ) 

IF  (M.GE.2)  GO  TO  1060 
ASAVE( I ) -DSTFC I ) *X( J3ND(M) ) 

IF  ( X( J) . LE . ASAVE( I ) )  JEDIT(I)-J 
IF  (X( J) .GE.ASAVE(I))  I-I+l 
GO  TO  1070 
1060  CONTINUE 
K-M-l 

ASAVEC I ) -X( JBND(K) )+DSTF( I ) * ( X( JBND(M) )-X( JBND(K) ) ) 
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IF  (X(J) .LE.ASAVE(I))  JEDIT(I)-J 
IF  (X( J) .GE.ASAVE(I))  I-I+l 
1070  CONTINUE 
1080  CONTINUE 

PRINT  ALL  NON-ENERGY  SOURCE  DEPENDENT  DATA 

WRITE  (6,1800) 

K-IABS(NRZC) 

K-MAXO ( K , 2 * NMTRLS - 1 ) 

WRITE  (6,1810)  (RZ(I),NZ(I),I-1,K) 

IF  (NRZC.EQ.O)  GO  TO  1290 
IF  (NJEDIT)  1100,1100.1090 
1090  WRITE  (6,1940)  (JEDIT(I) , 1-1 .NJEDIT) 

1100  IF  (NTEDT)  1110,1120,1110 

1110  WRITE  (6,1930)  (TEDIT( I ) , 1-1 .NTEDT) 

1120  WRITE  (6,1970)  NELT 
WRITE  (6,1960) 

C 

DO  1200  N-l.NELT 
WRITE  (6.1960) 

WRITE  (6,1980)  NAMEL(N) ,N 
IF  (NVARE(N) )  1130,1130,1140 
1130  WRITE  (6,2090) 

GO  TO  1150 
1140  WRITE  (6,2100) 

1150  IT-NOE(N) 

WRITE  (6,1890)  IT, ( AA(N , I ) , B(N , I ) , EDGE(N , I ) , 1-1 , IT) 
IF  ( NVARE(N) )  1160,1160,1170 
1160  WRITE  (6,2050) 

IT-NOEC(N) 

WRITE  (6,2060)  IT . (EDGEC(N , I) , 1-1 , IT) 

WRITE  (6,2070) 

GO  TO  1180 
1170  WRITE  (6,2080) 

1180  WRITE  (6,1990) 

IT-NTBL(N) 

WRITE  (6,2130) 

WRITE  (6,1750)  (XI(N,J),J-1,IT) 

WRITE  (6,2130) 

WRITE  (6,2000) 

WRITE  (6,2130) 

WRITE  (6,1750)  (EN(N,J) , J-l ,IT) 

IF  (JPRIN.EQ.O)  GO  TO  1200 
WRITE  (6,2130) 

WRITE  (6,2140) 

WRITE  (6,2160)  (NLEC(N, J) . J-l .6) 

WRITE  (6,2130) 

WRITE  (6,2150) 

DO  1190  1-1,6 
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1190  WRITE  (6.1750)  (EBB(N. I . J) . J-l , 14) 

1200  CONTINUE 

WRITE  (6.2130) 

WRITE  (6,1960) 

JB1-1 

DO  1280  M-l.NMTRLS 
WRITE  (6.1960) 

IF  ( JBND(M) )  1220.1210.1220 
1210  JB2-JFIN 

GO  TO  1230 
1220  JB2-JBND(M) 

1230  THKNS-X( JB2)-X( JB1 ) 

WRITE  (6.1850)  MATL(M)  ,RH0(M)  ,  «XB1 ,  JB2  .THKNS 
IF  (NVARM(M) )  1240,1240,1250 
1240  WRITE  (6,2110) 

GO  TO  1260 
1250  WRITE  (6,2120) 

1260  JB1-JB2 

WRITE  (6,1860)  EQSTC(M) , EQSTD(M) , EQSTE(M) , EQSTG(M) , EQSTH(M) , EQSTS 
1  (M) , EQSTN(M) , PMIN(M) 

WRITE  (6.1870)  CUSPl(M) ,CUSPA(M) ,CUSPC(M) ,CUSPD(M) ,CUSPG(M) .CUSPS 
1  (M) 

WRITE  (6,1880)  Y0(M) , AMU(M) , YADD(M) , YMU(M) ,EQSTA(M) ,OMEGA(M) 

1  , PRELAX ( M ) , SHEARR( M ) , TRELAX(M) .MFLAG(M) , AMU2(M) ,TRELX2(M) 

WRITE  (6.2010)  XCON(M) ,XMW(M) ,NATOH(M) 

IT-NELEM(M) 

WRITE  (6,2020)  (IELEM(M.N) ,N-1 . IT) 

NKEEP-1 

DO  1270  N-1,10 

IF  (AF(rl.N)  .  EQ.O)  GO  TO  1270 

AS AVE ( NKEEP ) - AF ( M . N ) 

NKEEP-NKEEP+1 
1270  CONTINUE 

WRITE  (6.2030)  (ASAVE(N) , N-l , IT) 

1280  CONTINUE 

WRITE  (6,1920) 

IF  (NRZC.LT.O)  GO  TO  1440 
1290  CONTINUE 
C 

C  READ  ENERGY  SOURCE  DATA 

C 

'  ANGLE-C0S( ANGLE/57. 2957795) 

DO  1430  NS-l.NSPEC 
C  FORMAT  WAS  8110 

READ  (5, * .END-1300)  NHNU(NS) ,NBB(NS) 

1300  NNU*  *arHNU(  ’  S ) 

NBBS-.  ”  S) 

C  FORMAT  .  .S  8E10 

READ  (5, ‘.END-1310)  START(NS) . SSTOP(NS) . (T(KX) .EE(KX) ,KX-1 .NBES) 

1  ,  XPRIN 
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1310  CONTINUE 

*  IF  DEF.B64 

SST0PM-AMAX1 ( SSTOPM , SST0P( NS ) ) - 

‘ENDIF 

*  IF  DEF.B32 

SSTOPM-DMAX1 ( SSTOPM , SSTOP ( NS ) ) 

‘ENDIF 

IF  (NNU)  1320,1350,1320 

FOR  ARBITRARY  SPECTRUM 

FORMAT  WAS  8E10 
1320  CONTINUE 

READ  (5, * .END-1330)  (TBL(I) ,ES(NS , I) . 1-1 ,NNU) 
1330  EITOT-O. 

DO  1340  II-l.NNU 

ES(NS , II )-ES(NS , II ) * ANGLE* EE ( 1 ) 

EITOT-EITOT+ES( NS . II ) 

1340  CONTINUE 

GO  TO  1390 

FOR  BLACK  BODY  SPECTRUM 

1350  EITOT-O. 

DO  1380  KX-l.NBBS 
DO  1380  1-1,109 
IF  (1-99)  1360,1360,1370 
1360  EITOT-EITOT+EE(KK) ‘ANGLE* .01 
GO  TO  1380 

1370  EITOT-EITOT+EE(KX) * ANGLE* .001 
1380  CONTINUE 

ENERGY  INPUT  EDIT 

1390  IF  (NNU)  1410,1400,1410 

1400  WRITE  (6,1770)  (TBL( I ) , 1-1 , 109) 

GO  TO  1420 

1410  IF  ( XPRIN . EQ .1.0)  GO  TO  1430 

WRITE  (6,1770)  (TBL( I ) , 1-1 , NNU) 

1420  WRITE  (6,1960) 

WRITE  (6,1950)  EITOT , NBBS , START( NS ) , SST0P( NS ) 
WRITE  (6,1820) 

WRITE  (6,1830)  (T(I) ,EE(I) ,1-1, NBBS) 

WRITE  (6,1960) 

1430  CONTINUE 

XFX(l) -EITOT 
XFL(l) -EITOT 

INITIALIZE  SPALL  COUNTERS 
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IS-C 

ISM-0 

■tub— -T  SPALL-0 
’.-40  CONTINUE 
C 

C  INITIALIZE  COUNTERS  AND  CONSTANTS 

C 

NRZ-50 

CO-1.8 

Cl- .25 

IT-1 

NTEDT-0 

LINE-0 

PDTPOS-O . 

PDTNEG-0 . 

I PLOW -0 

IF  ( ICON . EQ . 0 . OR . IDIF . EQ . 0 )  IFLOW-1 
IF  (NJEDIT)  1470,1470,1450 
1450  DO  1460  1-1, NJEDIT 
1460  JORGd)-JEDIT(I) 

1470  CONTINUE 
C 

C  CHECK  INPUT  DATA  VALUES 
C 

IF  (NPRIN.GT.O)  GO  TO  1490 
WRITE  (6,1720) 

1480  STOP 

1490  IF  ( JFIN.GT. 1 .AND. JFIN.LE.201)  GO  TO  1500 
WRITE  (6,1730) 

GO  TO  1480 
1500  CONTINUE 
C 

C  INITIALIZE  ZONE  VARIABLES 

C 

M-l 

DO  1530  J-2.JFIN 
Y0Z( J)-TO(M) 

V( J)-l . /RHO(M) 

ZM( J)-(X( J )-X( J-l ) ) *RHO(M) 

TEMP(J)-300. 

-  E( J)-2.5E8/XMV(M)»TEMP(J)*FL0AT(NAT0M(M)) 

GOVERK( J)-GOKE(M) 

SD2(J)-0. 

TSPALL( J )«ABS(PMIN(M) ) 

IF  (PMIN(M).EQ.O.)  TSPALL( J)-l .E15 
C 

c  TSPALL  IS  THE  NUMERICAL  VALUE  OF  THE  SPALL  CRITERIA 

C 

IF  ( J-JBND(M) )  153. .1510, 1530 
1510  CONTINUE 
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IF  (NRZC.EQ.O)  GO  TO  1520 
EM(M)-EM(M)+E(J) 

EQSTE(M)-EQSTE(M)+E(J) 

1520  CONTINUE 
M-M+l 

1530  CONTINUE 

TSPALL( l)-0. 

INITIALIZE  SPALL  VARIABLES. 

DO  1540  1-1,50 
SMCD-O. 

US(I)-0. 

XS(I)-0. 

1540  CONTINUE 

CALCULATE  ENERGY  DEPOSITION 

N-0 
JHAT-0 
ICHCK-0 
CALL  FLO ION 
ICHCK-1 

IF  (NRZC.NE.O)  GO  TO  1550 
DX-X(2 )+SQRT(EQSTC( 1 ) /RHO( 1 ) ) *SST0PM 
NRZC--1 
GO  TO  1040 
1550  CONTINUE 

DEPOSITION  EDIT 

WRITE  (6.1900)  (DISCPTC I ) , 1-1 , 8 ) 

M-l 

SUMCAL-0 . 

DO  1640  J-2.JFIN 
EPG-0 . 

DO  1560  I-l.NSPEC 

1560  EPG-SS( J , I ) * ( SSTOP( I )-START( I ) )+EPG 
IF  ( J-(JBND(M)+1))  1580,1570,1580 
1570  M-M+l 

1580  IF  ( EPG * EQSTGC M ) - 1 . E7 )  1590,1590,1610 
1590  IF  ( JSTAR)  1600,1600,1610 
1600  JSTAR-J 

1610  IF  (4 . E-l 1 *EPG*XMW(M) . GT . 1 . 2E4 )  JHAT-J+1 
DX-X( J)-X(J-l) 

ERGPA-EPG* RHO ( M ) *  DX 
CALPA-ERGPA* 1 . E-7/4 . 186 
SUMCA_,-SUMCAL+CALPA 

WRITE  (6,1910)  J , DX , X( J ) ,ERGPA , CALPA , SUHCAL , EPG , Y0Z( J ) , ZM( J ) 
1  , TSPALL( J ) 
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IF  ( MOD( J ,  50  )  )  1640,1620,1640 
1620  IF  ( J-JFIN)  1630.1640.1640 
1630  WRITE  (6,1900)  (DISCPT( I ) , 1-1 , 8 ) 

1640  CONTINUE 

JHAT-MINOC JFIN , JHAT) 

IF  ( JSTAR)  1650,1650,1660 
1650  JSTAR- JFIN 
1660  WRITE  (6,1920) 

C 

C  INITIALIZE  PLOT  VARIABLES. 

C 

DO  1670  1-1,201 
PSMAX(I)-0.0 
PSMIN( I )-0 . 0 
PX(I)-0.0 

IF  (I.GT.JFIN)  GO  TO  1670 
PX(I)-X(I) 

1670  CONTINUE 
JPRIN-0 
RETURN 
C 

1680  FORMAT  (' ONION- 1916) 

1690  FORMAT  ( ' OEION' , 15/ ( IX, 1P10E12.4) ) 

1700  FORMAT  ( 15H0FATAL  ERROR* **, 15 ,28H  ELEMENTS  INPUT  FOR  MATERIAL ,A10 , 
1  16H ,  LIMIT  IS  5  ***) 

1710  FORMAT  (BZ.A10) 

1720  FORMAT  (29HOERROR  -  NPRIN  MUST  BE  .GT.  0) 

1730  FORMAT  (41HCERR0R  -  JFIN  MUST  BE  .GT .  1  AND  ,LE.  201) 

1740  FORMAT  (BZ.8A10) 

1750  FORMAT  (8E10.3) 

1760  FORMAT  (46H  *****  THIS  PROBLEM  WAS  RUN  WITH  HIRAD  *****  /) 

1770  FORMAT  (13H  TABLE  VALUES/ ( 10E10 . 3 ,/) ) 

1780  FORMAT  ( / , 6X , 4HNRZC , 4X , 6HNMTRLS , 6X , 4HJRZL , 5X , 5HJZPUL , 5X , 5HNPRIN , 5X 

1  , 5HNTAPE , 6X , 4HNDEP , 4X , 6HL0ZHI Z , 6X , 4HJFIN , 5X , 5HJCYCS , 4X , 6HNREZ0N/ 1 

2  1110) 

1790  FORMAT  ( / , 14X , ' RSCRIT ' , 6X , ' RZCO '  , 6X , ' RZC1 ' / 15X , 1P3E10 -  3/ ) 

1800  FORMAT  (/12H  ZONING  USED/) 

1810  FORMAT  (3X.6H  RATIO , 1PE22 . 13 , 8H  TO  ZONE, 14) 

1820  FORMAT  (/17H  BLACK  BODY  INPUT/) 

1830  FORMAT  ( 12H  TEMPERATURE , 5X , 7H  ENERGY/ , 10( 2E12 . 3 ,/)  ) 

1840  FORMAT  ( / 5X , 5HANGLE . 6X , 4HTIME , 7X , 3HCKS , 8X , 2HTS , 6X , 4HNDEP/4E10 . 3 
1  .110) 

1850  FORMAT  ( / 25HCMATERI AL  PROPERTIES  FOR  , A10/5X , 4KRH0- , 1PE12 . 4 , 5X , 7HF 
1R0M  J-,14, 1X.5HT0  J- , 14 , 5X , 1 1HTHICKNESS  -.1PE12.4) 

I860  FORMAT  ( / 10X , 5HEQSTC, 10X , 5HEQSTD , 10X , 5HEQSTE , 10X , 5HEQSTG, 10X, 5HEQS 
1TK , 10X , 5HEQSTS , 10X . 5HEQSTN , 1 IX , 4HPMIN/ 1P8E1 5 . 5 ) 

1870  FORMAT  ( / 10X , 5HCUSP1 , 10X , 5HCUSPA , 10X , 5HCUSPC , 10X , 5HCUSPD , 10X , 5HCUS 
IPG , 10X , 5HCUSPS/ 1P8E15 . 5 ) 

1880  FORMAT  ( / 1 3X , 2HY0 , 1 2X , 3HAMU , 1 1 X , 4HYADD , 1 2X , 3HYMU , 1 OX , 5HEQSTA . 1 OX . 5 
1  HOMEGA , 9X , 6HPRELAX . 9X , 6HSHEARR/ 1P8E15.5//9X, 6HTRELAX , 1 OX , 5KMFLAG , 
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2  11X .4HAMU2 . 9X , 6HTRELX2 / 1 PE 1 5 .5,115, 1P2E15 . 5) 

1890  FORMAT  (/,6H  NOE  - . 13 , 19X , 2HAA , 14X , 1HB , 1 IX , 4HEDGE/ , 20( 15X , 3E15 . 5 / ) 

1  ) 

1900  FORMAT  ( 1H1 , 8A10/3H0  J.5X.3H  DX.12X.2H  X.10X.5H  ERGS , 1 OX , 4H  CAL.8X 

1  ,8H  SUM  CAL.6X.8H  ERGS/GM , 8X , 4H  Y0Z.7X.10H  ZONE  MASS ,6X,7H  TSPALL 

2  //) 

1910  FORMAT  ( 1H  . 13 , 1P9E14 .4) 

1920  FORMAT  ( 1H1 ) 

1930  FORMAT  (/15H  THE  TEDITS  ARE/ ( 10E10 . 3/ ) ) 

1940  FORMAT  (/15H  THE  JEDITS  ARE/ 10110/ ) 

1950  FORMAT  ( 5X , 5HEIT0T , 7X , 3HNBB , 5X , 5HSTART , 5X, 5HSST0P , / ,E10 .3,110, 2E10 
1  .3) 

1960  FORMAT  (//) 

1970  FORMAT  (//39H  NUMBER  OF  ELEMENTS  IN  THIS  PROBLEM  IS  ,110/) 

1980  FORMAT  (/12H  ELEMENT  IS  , A1 0 , 1 8 HELEMENT  NUMBER  IS  .110) 

1990  FORMAT  ('  IONIZATION  LEVELS  FOR  ZERO  TO  COMPLETE  IONIZATION  (IN',' 
1  EV)  ARE  ') 

2000  FORMAT  ('  IONIZATION  ENERGIES  PER  ATOM  (IN  EV)  FOR  ZERO  TO  COMPL '  ' 
1ETE  IONIZATION  ARE  ') 

2010  FORMAT  (/39H  ATOM  CONDUCTIVITY  OF  THIS  MATERIAL  IS  .E10.3/38H  MOLE 
1CULAR  WEIGHT  OF  THIS  MATERIAL  IS  .E10.3/37H  NUMBER  OF  ATOMS  IN  THI 
2S  MATERIAL  IS  ,110) 

2020  FORMAT  (/50H  ELEMENT  NUMBERS  WHICH  OCCUR  IN  THIS  MATERIAL  ARE  /10X 
1  .7110) 

2030  FORMAT  (/38H  ATOM  FRACTIONS  OF  THESE  ELEMENTS  ARE  /4X.7E10.3) 

2040  FORMAT  ( / , '  IF  ICON  EQUALS  ZERO  CONDUCTIVITY  IN  THE  VAPOR  STATE 

1  IS  ASSUMED  ,  ICON  FOR  THIS  PROBLEM  EQUALS  ',110/'  IF  IDIF  EQUALS 

2  ZERO  DIFFUSION  OF  ENERGY  IN  THE  MATERIALS  IS  ASSUMED  ,  IDIF  FOR  T 
SHIS  PROBLEM  EQUALS  ',110/) 

2050  FORMAT  (//'  ENERGY  OF  THE  EDGES  WERE  CALCULATED  BY  THIS  CODE  AS') 
2060  FORMAT  ( /7H  NOEC  - , 13 , 37X , 5HEDGEC/20(40X . E15 . 5/ ) ) 

207C  FORMAT  (//'  IONIZATION  POTENTIALS  AND  ENERGIES  WERE  CALCULATED  BY 
1  THE  CODE  FOR  THIS  ELEMENT) 

2080  FORMAT  (//'  IONIZATION  POTENTIALS  AND  ENERGIES  WERE  INPUT  FOR  THIS 

1  ELEMENT ' ) 

2090  FORMAT  (/'  THE  ABSORPTION  CROSS  SECTION  OF  THIS  ELEMENT  IS  VARIABL 
IE  UNLESS  THE  MATERIAL  IN  WHICH  IT  OCCURS  DOES  NOT  ACCEPT  VARIABLE' 

2  /X , 14HCR0SS  SECTIONS) 

2100  FORMAT  (/'  THE  ABSORPTION  CROSS  SECTION  OF  THIS  ELEMENT  IS  FIXED 
1  AT  ITS  COLD  VALUE ' ) 

2110  FORMAT  (/'  THE  ABSORPTION  CROSS  SECTIONS  OF  THE  ELEMENTS  IN  THIS 
1  MATERIAL  ARE  VARIABLE  UNLESS  NV ARE ( ELEMENT )  NOT  EQUAL  TO  ZERO') 
2120  FORMAT  (/'  THE  ABSORPTION  CROSS  SECTIONS  OF  THE  ELEMENTS  IN  THIS 
1  MATERIAL  ARE  FIXED  AT  THEIR  COLD  VALUES') 

2130  FORMAT  (/) 

2140  FORMAT  (37H  SUB -SHELLS  AT  NTMP  EQUALS  ONE  TO  SIX) 

2150  FORMAT  ( '  BOUND-BOUND  TRANSITION  ENERGIES  FOR  NTMP  EQUALS  ONE  TO 
1  SIX' ) 

2160  FORMAT  (8110) 

2 1 70  FORMAT  ( 1H0 , 4X , 4HTIME . 8X , 5HEMVBM , 7X , 6HEMVBM1 , 6X , 6HEMVBM2 , 6X , 6KEMVN 
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1EG.6X, 6HEMVP0S , 7X , 5HRERAD/ / ) 
END 
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‘DECK  HYDRO 

SUBROUTINE  HYDRO 
•IF  DEF.B32 

IMPLICIT  DOUBLEPRECISIONC A-H , O-Z) 

•ENDIF 


IMPORTANT  VARIABLES  LOCAL  TO  THIS  SUBROUTINE 

DAVG  THE  AVERAGE  DENSITY  FOR  CURRENT  AND  PREVIOUS 

CYCLE 

DISTE  THE  SPECIFIC  ENERGY  USED  THIS  CYCLE  IN  CAUSING 

PLASTIC  DISTORTION 

DOLD  THE  DENSITY  DURING  THE  PREVIOUS  CYCLE 

DU  THE  PARTICLE  VELOCITY  AT  THIS  ZONE  BOUNDARY 

MINUS  THAT  AT  THE  PREVIOUS  ZONE  BOUNDARY 

EMU  THE  QUANTITY  ( (RHO/RHOO)-! )  —  IF  LESS  THAN  ZERO 

THE  MATERIAL  IS  CONSIDERED  TO  BE  A  VAPOR 

VELS  THE  VELOCITY  STRAIN  USED  IN  CALCULATING  THE 

CHANGE  IN  DEVIATORIC  STRESS  IN  THE  DIRECTION 
OF  PARTICLE  MOTION  DURING  A  HYDRO  CYCLE  — 

EQUAL  TO  DV*DAVG 

VMC  THE  VON  MISES  YIELD  CRITERION  REQUIRES  VMC  EQUAL 

1.5*SD**2  BE  LESS  THAI'  0 -667*YIELDSTRENGTH*  *2 

* _ * _ * _ _* _ * _ * _ * _ * _ * _ « _ * 


CALL  BLANK 
CALL  EQVP 
CALL  PLOTCM 
CALL  RZCOM 
CALL  SPLLC 

DATA  STATEMENT 


DATA  ONE,  PI,  ZERO  / 1 ., 3 . 1415926536 , 0 .  / 


ENERGY  ADDITION  FOR  ZONES  EACH  HYDRO- STEP 


IF  ( TIME . GT . SSTOPM )  GO  TO  90 
DO  80  K-2 , JFIN 
EADD(K)-0.0 
DO  70  I-l.NSPEC 
IF  ( TIME-STARTC I ) )  70,70,10 
10  IF  (TIME-DTNH-SSTOP(I))  20,70,70 
20  IF  (TIME-DTNH-START(I))  30.30,40 
30  EADD(K)-EADD(K)+SS(K,I)*(TIME-STARTCI)) 
GO  TO  70 

40  IF  (T:M£-SST0P(D)  50,50,60 
50  EADD(K) ■EADD(K)+SS( K , I ) *DTNH 
GO  TO  70 
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60  EADD(K)-EADD(K)+SS(X.I)*(SSTOP(I)-TIME+DTNH) 

70  CONTINUE 
80  CONTINUE 
90  M-l 
LL-1 
MS-1 
JB( 1 )-l 

JB(M)  -  INDEX  OF  LEFT-HAND  BOUNDARY  OF  THE  FIRST  ZONE  TREATED  AS 
DISPERSIVE,  IF  THERE  IS  DISPERSIVE  MATERIAL. 

LEFT  BOUNDARY  CONDITIONS 

DUDT1--2 .  * (S(2)+Q(2)-S(  1 ) )/ZM(2) 

U( 1 )«U( 1 )+ . 5*DTN*DUDT1 
X( 1 )-X( 1 )+DTNH*U( 1 ) 

HYDRO  ZONE  LOOP 

DO  430  J-2.JFIN 
DOLD-1 ./V(J) 

QO(J)-Q(J) 

SDOLD-SDC J) 

YOZOLD-YOZ(J) 

CHANGE  MATERIAL  INDEX  AND  ADD  NEW  ACTIVE  ZONE 

IF  (J-JBND(M))  110,100,110 
100  LL-LL+1 

JBCLL)-JBND(M) 

110  IF  (J.LT.JFIN)  GO  TO  120 

U( JFIN)-U( JFIN)+DTN*(S( JFIN)+Q( JFIH) ) /ZM( JFIN) 

GO  TO  130 

VELOCITY  CALCULATION 
120  CONTINUE 

CHECK  FOR  SPALLED  ZONE 
IF  (TSPALL(J) .EQ. 1.234)  GO  TO  150 

DUDTS--2.0*(S( J+l)+Q( J+l)-S( J)-Q( J))/(ZM( J)+ZM( J+l ) ) 

DUDT2-DUDTS 

U( J)-U(J)+.5‘DUDT2*DTN 
130  IF  ( ABS(U( J) ) . LT . 1 . E-3)  U(J)-0.0 
DU-UC J)-U(J-l) 

IF  ( U ( J ) . EQ . ZERO )  GO  TC  140 
QQQ-ABSCDU/UCJ)) 

IF  (QQQ.LE.l .0E-10)  DU-0.0 
140  CONTINUE 
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C 

C  COORDINATE  CALCULATION 

C 

X( J)«X(J)-t-DTNH*U(J) 

C 

C  DENSITY  CALCULATION  ACTUALLY  SPECIFIC  VOLUME 

C 

V( J)-(X(J)-X(J-1))/ZM(J) 

GO  TO  160 
150  CONTINUE 
C 

C  VELOCITY,  COORDINATE,  AND  DENSITY  FOR  SPALLED  ZONE 
C 

I SPALL-3 

DUDT2— 2.  *(S(  J+l)+0(  J+1))/ZM(J+1) 

DUDTS-2  .  *  (  S(  J)+{?(  J)  )  /  ZM(  J) 

U(J)«U( J)+.5*DUDT2*DTN 

US ( MS ) -US ( MS )+ . 5 *DUDTS *DTN 

IF  ( ABS (  U  ( J  )  )  . LT . 1 . E-3 )  U(J)-0. 

IF  (ABSCUS(MS)) .LT.l .E-3)  US(MS)«0. 

DU -US ( MS ) -U ( J- 1 ) 

C 

C  COORDINATES  OF  SPALLED  ZONE 

C 

X( J)«X( J)+DTNH*U( J) 

XS ( MS ) -XS ( MS ) +DTNH  *  US ( MS ) 

C 

C  DENSITY  -  ACTUALLY,  SPECIFIC  VOLUME 
C 

V( J)-( XS(MS)-X( J-l ) )/ZM( J) 

160  CONTINUE 

DAVG-C  1 .  /V(  J)-fD0LD)/2  . 

DV( J)-DTNH*DU/ZM( J) 

C 

C  VISCOUS  STRESS  CALCULATIONS 

C 

IF  (MFLAG(M) .GT.O)  GO  TO  200 
170  CONTINUE 

IF  (DU+1 . )  180,190,190 
C 

C  VISCOUS  STRESS  FOR  NON  DISPERSIVE  MATERIAL 

C 

180  0( J)-(DU*C0*C0-C1*CS(J))*DU*DAVG 
IF  (Q(J)-1.E5)  190,220,220 
190  Q(J)«0. 

DU-O. 

GO  TO  220 

200  IF  (TSPALLC  J ) . NE . 8 . )  GO  TO  210 
C 

C  IF  TS PALL  -  8.,  TREAT  MATERIAL  AS  NON  DISPERSIVE  IN  CALCULATING 
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VISCOUS  STRESS  FOR  DISPERSIVE  MATERIAL 

JB(M)-J 
GO  TO  170 

210  XX«2.*(RH0(M)*CH(M)/0MEGA(M))**2/ZM( J) 

IF  DEF.B64 

QU ( J ) — XX * EQSTA ( M ) * OMEGA ( M ) * DU+DA VG * CO *  * 2 * C AMIN 1 ( DU , ZERO ) ) *  * 2 

END  IF 
IF  DEF.B32 

QU(  J)— XX*EQSTA(M) *0MEGA(M) *DU+DAVG*C0* *2* (DMIN1 (DU , ZERO) ) * *2 

END  IF 

0  (  J ) — XX * ( DUDT S - DUDT 1 ) + QU ( J ) 

STRESS  -  STRAIN  CALCULATION 


220  VELS  «*DV  (  J  )  *  DA VG 
IF  DEF.B64 

THETA— SD(  J ) /AMAX1  ( ONE ,  SDC  J )  ) 

ENDIF 
IF  DEF.B32 

THETA— SDC  J  )  /DMAX1  (  ONE ,  SD(  J)  ) 


BULK-DOLD * CS ( J ) * • 2 
STRAIN-1 .-RHO(M)*V(J) 

IF  (SHEARR(M) . EQ.ZERO)  GO  TO  230 
IF  (l./V(J)/RH0(M)-l. .LE.YMU(M))  GO  TO  240 
GOK-GOVERK ( J ) *  EXP ( SHE ARR (M)*(1./V(J) -DOLD ) / RHO ( M ) ) 
GOKOLD-GOVERK(J) 

DEF , B64 

GO VERX C J ) - AMIN 1 ( GOX , GOKE C M ) ) 


F  DEF.B32 

GO VERK C J ) -DMIN 1 ( GOX , GOKE C M ) ) 

:ndif 

VAMU( J) -BULK ‘(GOKOLD+GO VERK C J))/l .5 
GO  TO  260 

230  IF  ( STRAIN. LE. 0. )  GO  TO  250 
VAMUC  J ) -BULK* GOKE CM ) / . 75 
IF  (VAMUC J)-AMU(M)/ .75)  250,260,260 
240  VAMUC J)-BULK*GOVERK(J)/ .75 
GO  TO  260 

25C  VAMUC J)-AMU(M)/ .75 
260  CONTINUE 
CKSHR-1. 

V AMU  C  J ) -CKSHR  * V AMU  C  J ) 

SDC  J ) -SDC  J ) + VAMUC  J ) *  VELS 


MAXWELL  GEOMETRIC  DISPERSION  MODEL 

IF  ( AMU2CM) . EQ . 0 . . AND . TRELX2CM) . EQ. 0 . )  GO  TO  290 
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IF  ( STRAIN. LE. 0. )  GO  TO  270 
VAMU2-BULK * GOKE2 ( M ) / . 75 
GO  TO  280 

270  VAMU2-AMU2(M) / .75 
280  SD20LD-SD2 ( J ) 

SD2 ( J ) -SD2 ( J ) +VAMU2  *  VELS 

IF  C  TRELX2 ( M ) . LE . 0 . )  GO  TO  290 

TRAT-0 . 5  * DTNH / TRELX2 ( M ) 

SD2( J)-( SD2( J)-TRAT*  SD20LD) / ( 1 . +TRAT) 

290  CONTINUE 

VMC-1 . 5  *  SD( J ) *  SD( J ) 

YOZDEG-CXSHR *  YOZ ( J ) 

IF  ( VMC-YOZDEG’ YOZDEG/ 1 .5)  350,350,300 
300  Y0Z( J)-YOZ(J)+YADD(M)*ABS(DV( J))*DOLD/RHO(M)/( . 2-YMU(M))/V( J) 
YOZDEG-CXSHR*  YOZ  (  J ) 

IF  ( VMC-YOZDEG* YOZDEG/ 1.5)  350,350,310 
310  IF  (TRELAX(M) .LE.O. )  GO  TO  340 
YZDEGO-YOZOLD*CXSHR 
IF  (PRELAX(M) .EQ.O.)  GO  TO  320 

TRELAV-TRELAX( M ) * EXP ( - ( ABS ( SD( J ) ) - YOZDEG/ 1 . 5 ) / PRELAX ( M ) ) 

GO  TO  330 

320  TEELAV -TRELAX ( M ) 

330  SDC J)«(SD( J)- . 5*DTNH* (SDOLD+THETA* ( YZDEGO+YOZDEG) / 1 . 5) /TRELAV) / C 1 . 
1  +.5* DTNH/ TRELAV) 

GO  TO  350 

340  SD( J)-SD( J) * YOZDEG* SQRT( 1 . /VMC/ 1.5) 

350  IF  (STRAIN)  360.380,380 
360  CONTINUE 

IF  ( (E( J)+EADD( J)) .LT.EQSTE(M) )  GO  TO  370 
SD(J)«0. 

SD2(J)-0. 

370  CONTINUE 

380  DISTE-(SD( J)+SD2(J))*DV(J) 

EADDC  J ) «EADD( J ) +DI STE 
DUDT1 -DUDT2 

IF  ( I SPALL. GE. 2)  MS-MS+1 

I SPALL-0 

M-LL 

END  OF  CYCLE  CHECKS 

IF  (U(J))  430,390,430 
390  IF  (N-i)  400,400,410 
400  JSMAXI -JSMAX+10 

IF  (LOZHIZ)  410,420,410 

JSTAR  CALCULATION 

410  IF  (J- JSTAR)  430,430,420 
420  JSTAR- J-l 
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GO  TO  440 
430  CONTINUE 
JSTAR-JFIN 
44C  CONTINUE 

DISPERSIVE  MATERIAL  CALULATIONS 

Q( JSTAR+2)-0. 

DO  550  M-I.LL 

IF  (MFLAG(M) .EQ.O)  GO  TO  550 
JL-JB(M) 

JJL-JL+1 

IF  (M.EQ.NMTRLS)  GO  TO  450 
JJU-MINOC J3ND(M) , JSTAR+1 ) 

GO  TO  460 
450  JJU- JSTAR+1 
460  CSMAX-0. 

SPQMAX-0 . 

JSPQM-0 
TPQMAX-0 . 

JTPQM-0 

DO  520  J-JJL.JJU 

IF  (CS(J) .LE.CSMAX)  GO  TO  470 

CSMAX-CS(J) 

470  IF  ( TSPALLC J).NE. 1.234. AND. J.NE.JJU)  GO  TO  520 
JU-J 

IMPLICIT  SOLUTION  FOR  Q  IN  DISPERSIVE  MATERIAL 

IF  (JL.GE.JU)  GO  TO  510 
YY(JL)-0. 

ZZ(JL)-QCJL) 

IF  (TSPALL(JL) .EQ. 1.234)  ZZ(JL)-0. 

JJL-JL+1 
DO  48C  K-JJL.JU 

XX»2 . * (RHO(M) *CH(M) /OMEGA(M) )**2/ZM(K) 

Xl-2. /(ZM(K)+ZM(K+1)) 

X2»2 . / ( ZM( K- 1 ) +ZM( K) ) 

IF  ( K . EQ . J JL . AND . TSPALLC JL ) . EQ . 1 . 234 )  X2-2./ZM(K) 

IF  (K.EQ. JU. AND. TSPALLC JU) .EQ. 1 .234)  X1«2./ZM(K) 

A1-XX*X1 

A2-1 . +XX* ( X1+X2 ) 

A3-XX»X2 

A4-QU(K)«-XX*(S(K+1)*X1-S(X)*(X1+X2)+S(K-1)*X2) 

IF  (K.EQ. JJL. AND. TSPALLC JL) .EQ. 1 .234)  A4-A4-XX*S(K-1 ) *X2 
IF  (K.EQ. JU. AND. TSPALLC JU) .EQ. 1 .234)  A4-A4-XX»S(K+1 ) *X1 
A5«A2-A3*YY(K-1) 

YY(K)«A1/A5 

ZZ(K)-(A4+A3*ZZ(K-1))/A5 
480  CONTINUE 
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DO  500  I-JJL.JU 
<J  J  — JU  —  I +J  JL 

Q( JJ)«YY( JJ)*Q( JJ+1)+Z2C JJ) 

IF  ( JJ.EQ. JU.AND.TSPALL(JU) .EQ. 1 .234)  Q(JJ)-ZZ(JJ) 

SMAX  CALCULATION  FOR  DISPERSIVE  ZONES 

IF  (S( JJ)+Q( JJ) .LE.SPQMAX)  GO  TO  490 
SPQMAX«S( JJ)+Q( JJ) 

JSPQM-JJ 

TMAX  CALCULATION  FOR  DISPERSIVE  ZONES 

490  IF  CS( JJ)+Q(JJ) .GE.TPQMAX)  GO  TO  500 
TPQMAX-S ( J J ) +Q( J J ) 

JTPQM-JJ 
500  CONTINUE 
510  JL-JU 
520  CONTINUE 

IF  ( SPQMAX . LE . SMAX)  GO  TO  530 
SMAX-SPQMAX 
JSMAX-JSPQM 

530  IF  ( TPQMAX . GE . TMAX )  GO  TO  540 
TMAX-TPQMAX 
JTMAX-JTPQM 

540  IF  (JSTAR.GT. JU-1)  GO  TO  550 

RESET  JSTAR  IN  DISPERSIVE  MATERIALS 
*  IF  DEF.B64 

J AD- I FI X ( CSMAX * DTNH/ ( X ( JST AR+ 1 ) -X ( JSTAR ) ) ) 

‘ENDIF 
‘IF  DEF.B32 

JAD- IDINTC CSMAX ‘DTNH/ ( X( JSTAR+ 1 ) -X( JSTAR) ) ) 

•ENDIF 

JSTAR-MINOC JSTAR+l+JAD, JFIN-1) 

550  CONTINUE 
C 

END 


A- 78 


HYPUF  SOURCE  LISTING 


*DECK  OPAGUE 

SUBROUTINE  OPAGUE 
•IF  DEF.B32 

IMPLICIT  DOUSLfePRECISION(A-H.O-Z) 

•ENDIF 
•CALL  BLANK 
•CALL  AA 
•CALL  AC 
•CALL  EQFL 
•CALL  INDX 

DIMENSION  ENIK( 10 , 8 , 14) ,  ESJ(3,109),  ISTARTC 10,8),  NEDGLNC 10,8,3), 

1  NNIKC 10,8.19),  NOEI( 10,8),  SCREEN(14),  SHIFT( 10 , 8 . 14) ,  SNIK(10  8’ 

2  14) 

DATA  ISTART,  NNIK,  ENIK,  SHIFT,  SNIK,  NEDGLN  /80*0  1520«0  1120*0 
1  1120*0. , 1120*1 . ,240»0/ 

DATA  SCREEN  /14*0./ 

C 

C  THIS  PORTION  OF  THIS  ROUTINE  CALCULATES  THE  DEPOSITION  OF  ENERGY 
C  FOR  EITHER  CONSTANT  OR  VARIABLE  CROSS  SECTIONS 

C 

IF  (NVARM(M) )  10,10,620 
10  DO  610  Nl-l.NEM 
N-IELEM(M.Nl) 

KK-NOEC(N) 

KC-ITABL(KX) 

IF  (NVARE(N) )  20,20.30 
20  IF  ( ZF(N , J)-0 . 5)  30.30,60 
C 

C  WHEN  NV ARE ( ELEMENT )  IS  NOT  EQUAL  TO  ZERO.  CROSS/ SECTIONS  ARE 
C  FIXED  AT  COLD  VAULE  —  THUS  SOME  CONSTANTS  MUST  BE  SET 

C 

30  DO  40  K-1,14 
40  SNIK(N,1,K)«1. 

DO  50  K-1,19 
50  NNIK(N,1 .K)-NION(N.K) 

GO  TO  610 
C 

C  CALCULATE  ALL  SCREENING  CONSTANTS  FOR  THIS  ELEMENT  IN  EACH  OF  SIX 
C  CALCULATED  ION  STATES. 

C 

60  KN-KMAX(N) 

DO  600  Kl-l.KN 
NELEC«NTBL(N)-NI(X1 ,N) 

JI-NICK1 ,N) 

IF  ( JI . EQ . 0 . AND . ION . EQ . 1 )  GO  TO  570 
IF  ( JI . GE . NTBL(N) )  GO  TO  600 
IF  CK1 .NE. 1 . AND. ION.EQ.O)  GO  TO  340 
IF  (ION.EQ.O)  NELEC-NTBL(N) 


A-  79 


no  non 


HYPUF  SOURCE  LISTING 


FIND  THE  NUMBER  OF  ELECTRONS  IN  EACH  SUB-SHELL  FOR  THIS 

ION  STATE  IF  ION  EQUALS  1  OR  FOR  THE  NEUTRAL  ATOM  IF  ION  EQUALS  0. 

DO  70  K-1,14 
70  NSPDF(K)-0 
DO  80  K-1,19 
NSUM(K)-0 
80  NGRUP(K)-0 

IF  (NELEC-78)  110,110,90 
90  DO  100  K-1,6 
100  NGRUP(K+13)«ITBL(NELEC,K) 

GO  TO  250 

110  IF  (NELEC-69)  140,140,120 

120  DO  130  K-1,6 

130  NGRUP(X+10)-ITBL(NELEC,K) 

GO  TO  270 

140  IF  (NELEC-46)  170,170,150 

150  DO  160  K-1,6 

160  NGRUP ( K+9 ) « ITBL ( NELEC , K ) 

GO  TO  280 

170  IF  (NELEC-28)  200,200,180 

180  DO  190  K-1,6 

190  NGRUP( K+6)«ITBL( NELEC , K) 

GO  TO  300 

200  IF  (NELEC- 10)  230,230,210 

210  DO  220  K-1,4 

220  NGRUP (K+3)-ITBL( NELEC, K) 

GO  TO  320 
230  DO  240  K-1,3 
240  NGRUP(K)-ITBLCNELEC.K) 

GO  TO  380 
250  DO  260  K-1,3 
260  NGRUP(K+10)-ILTBL5(K) 

270  NGRUP ( 10 )-ILTBL4(l) 

280  DO  290  K-1,3 

290  NGRUP (K+6)-ILTBL3(K) 

300  DO  310  K-1,3 

310  NGRUPC  K+3 ) - ILTBL2 ( K ) 

320  DO  330  K-1,3 
330  NGRUPC K)-ILTBLl(K) 

IF  (ION.EQ.l)  GO  TO  380 

FIND  THE  NUMBER  OF  ELECTRONS  IN  EACH  SUB-SHELL  FOR  THIS  ION  STATE 
ION  EQUALS  0 
NELEC-NTBL(N)-NI(X1 ,N) 

340  NSUM1-0 

DO  350  K-1,19 

NSUM 1 -N  SUM 1 +NGRUP ( K ) 

NSUM(K)-NSUM1 

IF  ( NSUM 1 .GE. NELEC)  GO  TO  360 
350  CONTINUE 
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360  NGRUP(K)-NELEC-NSUMCK-l) 

KXEEP-K+1 
DO  370  K-KXEEP.19 
370  NGRUP(K)-C 

IF  (JI.EQ.O)  GO  TO  570 

CALCULATE  THE  NUMBER  OF  ELECTRONS  IN  EACH  OF  THE  SUB-SHELL  GROUPS 
NEEDED  IN  SCREENING  CONSTANT  CALCULATE IONS  — S+P ,  D,  OR  F  — 

380  NSPDFC l)-NGRUP(l) 

NS PDF ( 2 ) -NGRUP ( 2 ) +NGRUP ( 3 ) 

NSPDFC 3 ) -NGRUP( 4 ) +NGRUPC 5 ) 

NSPDF(4)«NGRUP(6) 

NS  PDF ( 5 ) -NGRUP ( 7 ) +NGRUP ( 8 ) 

NSPDF ( 6 ) -NGRUPC  9 ) 

NSPDF ( 7 ) -NGRUP (10) 

NS PDF ( 8 ) -NGRUP ( 1 1 ) +NGRUP ( 1 2 ) 

NSPDF( 9) -NGRUP( 13) 

NSPDFC 10)-NGRUP( 14) 

NS PDF ( 1 1 ) -NGRUP ( 1 5 ) +NGRUP ( 16 ) 

NSPDFC 12)-NGRUP( 17) 

NS  PDF ( 1 3 ) -NGRUP (18) 

NS PDF ( 1 4 ) -NGRUP ( 19 ) 

CALCULATE  THE  TOTAL  NUMBER  OF  ELECTRONS  UP  TO  AND  INCLUDING 
THOSE  IN  EACH  SUB-SHELL 

NSUM1-0 

DO  390  K-1,19 

NSUM1-NSUM1+NGRUPCK) 

390  NSUM(K)-NSUM1 

FIND  THE  NUMBER  OF  SCREENING  CONSTANTS  —  OR  SUB-SHELLS  — 
ASSOCIATED  WITH  THIS  ATOM  OR  ION  STATE  -  CALL  IT  K3 

DO  400  K-1,19 

IF  (NELEC-NSUM(K) )  410,410,400 
400  CONTINUE 
410  NOEI ( N ,K1 )-K 
KI-K 

KI-ITABL(K) 

DO  540  K2-1 ,K3 
NSTMP-NSPDFC  K2)-l 
N  S  PDF ( K2 ) -MAXO ( NSTMP . 0 ) 

CALCULATE  THE  SCREENING  CONSTANTS 

NPREVT -NSPDFC  1 )  -rNSPDFC  2  ) 

IF  (K3.GE.5)  GO  TO  420 
GO  TO  (460,450,440,430),  K3 


A- 81 


ooooooo  noo 


HYPUF  SOURCE  LISTING 


CALL  GOTOER 

420  NPREVS-NSPDF(3)+NSPDF(4) 

SCREEN ( 5 ) -FLOAT ( NTBL ( N ) -NPREVT ) -0 . 8  5  *  FLOAT  C  NPREVS ) -0 . 35  *  FLOAT ( MAXO 
1  (NSPDF(S)-l ,0) ) 

430  SCR£EN( 4 ) - FLO AT ( NTBL ( N ) -NPREVT-NSPDFC 3 ) ) -0 . 35  *  FLOAT ( MAXO ( NS PDF (  4  )  - 
1  1,0)) 

440  SCREEN C 3 ) -FLOAT ( NTBL ( N ) -NSPDFC 1 ) ) -0 . 85  *  FLOAT ( NSPDFC  2 ) ) -0 . 35 ‘FLOAT 
1  ( MAX0( NSPDFC 3)-l ,0)) 

450  SCREEN ( 2 ) -FLOAT( NTBL( N ) )-0 . 85 ‘FLO AT (NSPDFC 1 ) )-0 . 35 ‘FLOAT C MAXO 
1  ( NSPDF (2)-l,0)) 

460  SCREENC 1 ) -FLO AT ( NTBLC N ) ) -C . 3 * FLO AT ( MAXOC NSPDFC 1 ) - 1 , 0 ) ) 

IF  (K3.LE.5)  GO  TO  490 
NPREVT-NPREVT+NPREVS 
NPREVS -NSPDFC 5) 

KX-5 

470  DO  480  K4-1.2 
K5-KX+K4 

SCREEN ( K5 ) - FLOAT ( NTBL ( N ) -NPREVT -NPREVS ) -0 . 35  *  FLOAT ( MAXO ( N S PDF ( KS ) - 
1  1,0)) 

NPREVS-NPREVS+NSPDFC  K5 ) 

IF  (K3.LE.5)  GO  TO  490 
480  CONTINUE 
KX-KX+3 

SCREEN ( KK ) -FLOAT ( NTBL ( N ) -NPREVT ) -0 . 8  5  »  FLOAT ( NPREVS ) -0 . 35 ‘ FLOAT 
1  (MAXO(NSPDF(KK)-l.O)) 

NPREVT-NPREVT+NPREVS 

NPREVS-NSPDF(KK) 

IF  (KX.LT.K3)  GO  TO  470 

CALCULATE  THE  ENERGY  OF  THIS  ION  STATE 

490  K4-KC+1-K2 

ENIK(N,K1,K4)«0. 

DO  500  K-1.K3 

500  ENIKCN , XI , K4)«ENIK(N , K1 , K4)+SCREEN(K) *  *2 ‘FLOAT C NSPDFC K) ) /XNSTARC  K) 
ENIKCN.Kl ,K4)-1 . 356E-2*ENIX( N , XI ,K4) 

DIVIDE  THE  VALUE  OF  THE  SCREENING  CONSTANT  ASSOCIATED  WITH  THIS 
SUB-SHELL  BY  THE  VALUE  OF  THIS  SAME  CONSTANT  FOR  THE  UNIONIZED 
ATOM  AND  STORE  AS  SNIXC ELEMENT , IONIZATIONLEVEL . SUB-SHELL)  -- 
ALSO  STORE  THE  VALUE  OF  THE  NUMBER  OF  ELECTRONS  IN  THE 
SUB-SHELL  GROUPS  —  S,  P,  D,  AND  F  —  AS  NNIK(N.Kl.K) 

SNIKCN , K1 ,K4) -SCREENC K2) 

IF  (NSTMP.LE.O)  GO  TO  530 
IF  (K2-1 )  510.510,520 
510  SNIKCN, XI ,X4)-SNIK(N ,X1 ,K4)-0.3 
GO  TO  530 

520  SNIKCN, XI , K4 ) -SNIXC N, XI ,K4) -0.35 

530  SNIKCN, XI ,X4)-SNIK(N,K1 , K4 ) / SCRENOC N , K4) 
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540  NSPDF(K2)-NSTMP+1 
DO  550  K-l , KI 
KL-NOEC(N)+l-K 
550  NNIK(N,K1 .KL)-NGRUP(K) 

DO  560  K-l , 14 
560  NSNIKCN.K1 ,K)»NSPDF(K) 

GO  TO  600 
C 

C  RESET  FOR  HI  -  0 

C 

570  DO  580  K-l, 14 
580  SNIK(N,1,K)«1. 

DO  590  K-l , 19 
590  NNIK(N,1 .K)-NION(N.K) 

IF  (NVARE(N).EQ.1.0R.ZF(N,J).LE.0.5)  GO  TO  610 
600  CONTINUE 

IF  ( J.EQ. JTS.AND. JPRIN.EQ.l)  WRITE  (6,1230)  N , ( ( ENIK(N , Kl . K) ,K-1 , 1 
1  4) ,K1-1 ,8) 

610  CONTINUE 
GO  TO  650 
C 

C  WHEN  NVARMC MATERIAL)  IS  NOT  EQUAL  TO  ZERO,  THE  X-SECTIONS  OF  ALL 

C  THE  ELEMENTS  ARE  FIXED  AT  THE  COLD  VALUE  —  SOME  CONSTANTS 

C  MUST  BE  SET 

C 

ENTRY  OPAGC 
620  CONTINUE 

DO  640  Nl-l.NEM 
N-IELEM(M.Nl) 

DO  630  K-l, 14 
630  SNIK(N,1,K)-1. 

DO  640  K-l, 19 
640  NNIK(N , 1 ,K)-NION(N ,K) 

C 

C  CALCULATE  THE  ENERGY  DEPOSITION  IN  THIS  ZONE 

C 

650  DO  1220  NS-1 , NSPEC 

IF  (J.EQ. JTS.AND. JPRIN.EQ. 1)  WRITE  (6,1240)  ( (NNIK( 1 ,N1 ,K) ,K«1 , 19) 
1  .Nl-1,8) 

IF  (TIME-START(NS))  1220,1220,660 
660  IF  (TIME-SSTOP(NS))  670,670,1220 
670  NNU-NHNU(NS) 

NBBS-NBB(NS) 

SS( J,NS)-0. 

ESUM-0 . 

IF  (J-2)  680,680,750 
680  CONTINUE 

*  IF  DEF.B64 

SDURM-AMIN1 ( SDURM , SSTOP(NS ) -START(NS ) ) 

*  ENDIF 
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*  IF  DEF.B32 

SDURM-DMIN1 ( SDURM , SSTOP( NS ) - START ( NS ) ) 

*ENDIF 

IF  (NNU)  690,710,690 
690  DO  700  I-l.NNU 
700  ESJ( 1 , I )-£S( 1,1) 

GO  TO  760 

710  DO  740  L-l.NBBS 
DO  740  1-1,109 
IF  ( 1-99)  720,720,730 
720  ESJ(L , I )«£E(L) * ANGL£*0 .01 
GO  TO  740 

730  ESJCL , I )-EE(L) * ANGL£*0 . 001 
740  CONTINUE 

750  IF  (NNU.EQ.O)  NNU-109 
C 

760  DO  1210  L-l.NBBS 

IF  (  JPRIN  . NE . 1 .OR . J . NE . JTS . OR. NKEEP/NPRIN’NPRIN . NE . NKEEP )  GO  TO  77 
1  0 

WRITE  (6.1300)  NS,L,T£MP(J) 

770  DO  780  Nl-l.NEM 
N-IELEM(M.Nl) 

KMAX(N)-MINO(NTBL(N) .8) 

KN-KMAX(N) 

DO  780  Kl-l.KN 
780  ISTART(N,Kl)-0 
DO  1200  I-l.NNU 

IF  ( ESJ(L , I )-l . E-20)  1200,1200,790 
790  ACION-O. 

IPRIN-0 

IF  (KPRIN.NE.O.AND. J.EQ. JTS. AND. 1/10*10. EQ. I)  IPRIN-1 
ZBAR-0 . 0 

DO  1170  Nl-l.NEM 
C  N  IS  ELEMENT  INDEX 

N-IELEMCM , N1 ) 

KN  IS  NUMBER  OF  CALCULATED  EDGES  (NUMBER  OF  OCCUPIED  ELECTRON 
SUB- SHELLS- IS , 2S , 2P , 3S , 3P , 3D . 4S  ETC) 

KN-NOEC(N) 

KNI  IS  KN  WITH  S+P  SUBSHELLS  CONDENSED  INTO  ONE  GROUP  FOR  EACH  N 
KNI-ITABL(KN) 

KGO  IS  THE  NUMBER  OF  DEGREES  OF  IONIZATION  (BEFORE  XRAY  EVENT) 

TO  INCLUDE  CONTRIBUTIONS  TO  X  SEC 
KGO-KMAX(N) 

IF  (J-JHAT)  800,800,840 
800  IF  (NVARM(M))  840,810,840 
810  IF  (NVARE(N))  840,820,840 
820  IF  ( TEMP ( J ) - 1 . 2E4 )  840,840,830 
830  IF  (ZF(N,J)-0.5)  840,840,850 
C  ATOM  IS  COLD-XSEC  IS  CONSTANT 

840  KGO-1 
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JI-C 

NOEKN.l  )-KN 

850  RHON«XAW(N)*FLOAT(NATOM(M))*AF(M,N)/XMW(M)/V(  j) 

IF  (IPRIN.EQ.O)  GO  TO  860 

WRITE  (6.1280)  J.N.TIME 

WRITE  (6.1310)  I .NAMEL(N) ,ZF(N, J) ,KG0 

WRITE  (6,1250)  KN . KNI . KGO . KMAX(N) , (NOEI (N , I J) . I «J«1 . 8 ) . ( NLEC(N . I J) 
1  .IJ-1 .6) .(NI(IJ.N) .IJ-1 .8) 

CALCULATE  CONTRIBUTIONS  TO  XSEC  FROM  THE  VARIOUS 
DEGREES  OF  IONIZATION 

860  DO  1160  Kl-l.KGO 

INITIALIZE  THE  ABSORPTION  EDGE  FOR  THIS  STATE  OF  THE  ELEMENT  TO 
THE  LOWEST  POSSIBLE  AND  FIND  HIGHEST  ACTIVE  EDGE 

KI  IS  HIGHEST  OCCUPIED  SUBSHELL 
KI-NOEI(N.Kl) 

IF  (KGO.EQ.l)  GO  TO  880 

NUMBER  OF  ELECTRONS  PREVIOUSLY  REMOVED 

JI-NKK1  ,N) 

IF  ALL  ELECTRONS  ARE  GONE.  THERE  IS  NO  INTERACTION 
IF  (JI.GE.NTBL(N))  GO  TO  1160 
DO  870  NTMP-1,15 
NTMP 1 - 16-NTMP 

IF  (KI.LE.NLEC(N.NTMPl))  GO  TO  890 
870  CONTINUE 
880  NTMP-0 

GO  TO  900 

INDEX  NTMP  USED  FOR  BOUND-BOUND  TRANSITIONS 
890  NTMP -NTMP 1 

900  IF  (ISTART(N.Kl))  910,910,970 
910  NEDGLN(N.K1 ,L)«KN+1-KI 

K2  IS  LOWEST  ACTIVE  EDGE -CORRESPONDS  TO  HIGHEST  OCC  SHELL  KI 
K2-N£DGLN(N,K1 ,L) 

K3-KN+1 -K2 
K3-MAX0(K3, 1) 

K3  IS  EDGE  NUMBER  K2  WITH  WITH  S+P  SHELLS  CONDENSED 
AND  COUNTS  IN  REVERSED  ORDER  OF  ENERGY  DECREASING 
THE  ELECTRON  TO  BE  REMOVED  FROM  SUB- SHELL  CORRESPONDING  TO  K3 
K3-KNI + 1 - ITABL( X3 ) 

IF  (IPRIN.EQ.l)  WRITE  (6,1260)  N,K1,L,K2,K3 
IF  ( KGO.EQ.l. OR. JI.EQ.O)  GO  TO  920 
SHIFT  IS  I (N , J , K)  -  I(N.O.K)  IN  MANUAL 

EION(N.JI)  IS  ELECTRON  BINDING  ENERGY  REMAINING  IN  ION  WITH 
JI  ELECTRONS  REMOVED  (PRIOR  TO  XRAY  INTERACTON) 

ENIK(N,K1 ,K3)  IS  BINDING  ENERGY  LEFT  AFTER  REMOVING  AN 
ELECTRON  FROM  SHELL  K3 .  FROM  THE  ABOVE  ION 
EDGEC( N , K2 )  IS  CALCULATED  EDGE  K2 
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SHIFTC  N . K1 , K3 ) -EIONCN , JI )-ENIKC N ,  K1  , K3)-EDGECCN ,K2 ) 

GO  TO  930 

920  SHIFTC N, 1 ,K3)-0.0 

930  IF  (NTMP.NE.O.AND. JI.NE.O)  GO  TO  940 
RBB-1 .0 
GO  TO  950 

C  RBB  IS  ENERGY  FRACTION  FOR  BOUND-BOUND  TRANSITIONS 
940  RBB-EBBCN.NTMP.K3) 

RBB-RBB/C EIONCN, JI)-EHIK(N,K1 ,K3)) 

IF  C  RBB . LE .0.0)  RBB-1. 0 

C  SKIP  CALCULATION  IF  LOWEST  EDGE  IS  GREATER  THAN  PHOTON  ENERGY 

950  IF  (TBLC I )*TCL)-RBB*  CEDGECN ,K2)+SHIFTCN,K1 ,K3) ) )  1160,1160,960 
960  ISTARTCN ,K1 )-l 
GO  TO  980 

970  K2-NEDGLNCN,K1 ,L) 

980  K4-KN-K2 

K4-MAX0CK4.1) 

C  K4  IS  EDGE  NUMBER  K2  WITH  WITH  S+P  SHELLS  CONDENSED 
C  COUNTING  IN  REVERSED  ENERGY  ORDER 

C  THE  ELECTRON  TO  BE  REMOVED  FROM  SUB-SHELL  CORRESPONDING  TO  K4 
K4 -KNI + 1 - ITABLC K4 ) 

IF  CIPRIN.EQ.1)  WRITE  C6,1270)  K2.K4 
IF  ( KGO . EQ . 1 . OR . JI . EQ . 0 )  GO  TO  990 
C  CHANGED  FOLLOWING  EDGEC  INDEX  FROM  K2+1 

SHIFTCN,K1,K4)-£I0NCN,JI)-ENIK(N,K1,K4)-EDGECCN,MIN0(K2+1,KN)) 

GO  TO  1000 

990  SHIFTCN , 1 ,K4)-0 . 0 
1000  IF  CNTMP.NE.O. AND. JI.NE.O)  GO  TO  1010 
RBB-1 .0 
GO  TO  1030 

1010  RBE-EBBCN ,NTMP ,X4) 

KNN-KC+1-K4 

IF  CNSNIF''N,K1 ,KNN) . EQ.O)  GO  TO  1020 
RBB-RBB/ C  EIONCN , JI ) -ENIKCN , K1 , K4 ) ) 

1020  CONTINUE 

IF  CRBB.LE.O.O)  RBB-1. 0 

C  CHECK  IF  EDGE  K2+1  IS  LESS  THAN  PHOTON  ENERGY 
1030  IF  C TBLC I ) *TCL)-RBB* ( EDGECN ,  K2+1 )+SHIFT(N , K1 , K4) ) )  1050,1050.1040 
C  INCREMENT  K2  TO  FIND  HIGHEST  ACTIVE  EDGE 

1040  K2-K2+1 
C 

C  .  .  IF  K2  . GT .  KN.  RESET  TO  KN  AND  BREAK  OUT  OF  LOOP 

C 

IF  CK2.LE.KN)  GO  TO  980 
K2-MIN0CK2.KN) 

1050  NEDGLNC N , K1 , L) -K2 

IF  C IPRIN .EQ.O)  GO  TO  1070 
WRITE  C6.1320)  K1 . K2 , K4 , NTMP , RBB 
IF  CRSB.EQ.l)  GO  TO  1060 

IF  C  EDGECCN ,  K2+1 )  .  EQ  .  0 . 0)  EDGEC(N  ,  K2+1  )-EDGE(  N  ,  K2+1 ) 
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WRITE  (6,1330)  EION( N , JI ) , ENIK(N , K1 ,K4) , EDGECC N ,K2+1 ) 

1060  CONTINUE 

WRITE  (6,1340) 

C 

C  TBL( I ) *T(L) . 

C 

1070  KX-KN+l-KI 

IF  (KX-K2)  1080.1080,1160 

C  LOOP  OVER  ALL  ACTIVE  EDGES  K  (AN  ELECTRON  REMOVED  FROM 
C  CORRESPONDING  SUB-SHELLS 

1080  DO  1150  K-KK.K2 

IF  (AA(N,K) )  1150,1150,1090 
1090  KJ-MINO(K.KN) 

K3-KN+1-KJ 

K3-MAX0(K3,1) 

K3-KNI + 1 -ITABLC K3 ) 

C  POPULATION  OF  IONS  WITH  DEGREE  JI 
P0P-R(K1 ,N) 

JI-NKK1  ,N) 

IF  (KGO.NE.l .AND. JI.NE.O)  GO  TO  1100 

IF  (KGO.EQ.l)  POP-1.0 

JI-0 

SHIFT(N,l,K3)-0.0 
GO  TO  1110 

1100  SHIFTCN , K1 , K3 ) -EION( N , JI ) -ENIK(N , K1 , K3) -EDGEC(N , KJ) 

C  NION  IS  NUMBER  OF  ELECTRONS  IN  EACH  SUB-SHELL  IN  COLD  ATOM 
1110  IF  ( JI . GE . NTBL( N ) . OR . NION ( N , KJ ) . EQ . 0 )  GO  TO  1150 
IF  (TBL( I ) *T(L)-SHIFT(N ,K1 , K3) )  1120,1120,1130 
1120  ETMP-TBL(l)*T(L)/2.0 
GO  TO  1140 

1130  ETMP«TBL(I)*T(L)-SHIFT(N,K1 ,K3) 

C  NNIK  IS  NUMBER  OF  ELECTRONS  IN  EACH  SUBSHELL  K  IN  ION  PRIOR  TO 
C  X-RAY 

1140  ACION-ACION-RHON*POP*AA(N,K)‘ETMP**(B(N,K)+1 . )*FL0AT(NNIK(N,K1 ,KJ) 
1  )/FLOAT(NION(N.KJ))*SNIK(N,Kl , K3 ) * • 5/ ANGLE 
IF  (IPRIN.EQ.O)  GO  TO  1150 

WRITE  (6.1350)  K , K3 , RHON , POP , JI , NNIK(N , K1 , KJ) . NION(N , KJ) , SHIFT(N 
1  ,K1,K3)  SNIK(N , El , K3) , AA(N , K) , B( N ,K) , AC ION , ETMP 
IF  (SHIFT(N,K1,K3).EQ.0.)  GO  TO  1150 

WRITE  (6,1360)  EION(N, JI) ,ENIK(N,K1 ,K3) .EDGEC(N.KJ) , SCRENO ( N , K3 ) 
1150  CONTINUE 
1160  CONTINUE 

1170  ZEAR-ZBAR+AF(M,N)*ZF(N, J)**2 
ACION-ACION/TBL( I)/T(L) 

IF  (IPRIN.EQ.l)  WRITE  (6,1370)  I.ACION 
IF  ( TEMP ( J ) . LT . 1 . 2E4 )  GO  TO  1180 

ACION-ACION-9 . 9E3* ( FLOAT ( NATOM(M) ) /XMW(M) ) *  * 2*  ZBAR* ZFM( J) / (TBL( I ) 

1  *T( L) ) *  *  3 /TEMP ( J )**0.5/V(J)**2 
C 

C  CALCULATE  THE  ENERGY  DEPOSITION  IN  THIS  ZONE  FROM  THIS  SOURCE 
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1130  AX1-ACI0N* ( X( J)-X( J-l ) ) 

IF  ( J.EQ.2.0R. J.EQ.20.0R. J.EQ.54)  AX2--ACI0N/RH0N 

IF  C J.EQ.2.0R. J.EQ.20.0R. J.EQ.54)  WRITE  (7,1290)  J , TIME , AX2 

IF  (AX1.LT.-20.)  EIZ-ESJ(L.I) 

IF  (AX1.LT.-20.)  GO  TO  1190 

£IZ-ESJ(L , I ) * ( 1 . -£XP( ACION* ( X( J )-X(J-l)))) 

1190  ESJ(L, I )— ESJ(L, I )-EIZ 
ESUM-ESUM+EIZ 

C  STORE  X-RAY  FLUX  IN  XFX(J) 

XFX( J)-XFX( J)+ESJ(L , I )/ ( SSTOPCNS )-START(NS) ) 

1200  CONTINUE 
1210  CONTINUE 

CALCULATE  THE  ENERGY  DEPOSITION  RATE  IN  THIS  ZONE  FOR  EACH 
SPECTRUM  IN  UNITS  OF  ERGS /GRAM /SECOND 

SS( J,NS)-ESUM*4. 186E7*V(J)/(X(J)-X(J-l))/(SSTOP(NS)-START(NS)) 

1220  CONTINUE 
RETURN 
C 

1230  FORMAT  ( ' OENIK ' , I5/( IX . 1P10E12 .4/ IX ,4E12 . 4) ) 

1240  FORMAT  ( ' ONNIK- ' . 1916) 

1250  FORMAT  ( ' OKN ,KNI .KGO .KMAX-NOEI-NLEC-NI ' ,418/ IX , 818/ IX ,618/ IX , 818 ) 
1260  FORMAT  (' ONEDGLN( ', 315 ,')-', 218) 

1270  FORMAT  (’0K2.X4  SET-', 218) 

1280  FORMAT  ( /5X , 20HFLOION  CALC  FOR  ZONE. 13, 7H  CYCLE  ,I4,6H  TIME-.1PE10 
1  .3) 

1290  FORMAT  (15 , 2( 1PE15 . 8 , 2X) ) 

1300  FORMAT  C///31H  CALCULATIONS  FOR  ZONE  2 , NSPEC- , 12 , 20X , 4HNBB- , 12 , 20X 
1  , 5HTEMP- , Ell . 3) 

1310  FORMAT  (/17H  ENERGY  INTERVAL- , 13 , 3X , 11HELEMENT  IS  . A10 , 3X , 14HI0NIZ 
1ATI0N  IS  , El 1 . 3 , 3X , 27HNUMEER  OF  ACTIVE  LEVELS  IS  ,12) 

1320  FORMAT  (14H  LEVEL  NUMBER- , 12 , 20X , 32HHIGHEST  NUMBERED  ACTIVE  EDGE  I 
IS  ,I2/4H  K4- , 12 , 10X , 5HNTMF- , 12 , 1  OX . 4HRBB- , El 1 . 3) 

1330  FORMAT  (6H  EION- , 1PE13 . 5 , 10X , 5HENIK- ,E13 . 5 , 10X , 10HNEXT  EDGE-, Ell. 3 
1  ) 

1 340  FORMAT  ( IX . 4 HEDGE , 6X , 7HS+P , D , F . 5X , 3HRH0 , 9X . 3HP0P . 5X , 2HJI . IX , 4ENNIK 
1  , IX , 4HNI0N , 3X , 5HSHIFT , 8X , 4HSNIX , 9X . 2HAA , 10X , 1HB . 10X , 2HMU . 8X , 4HETM 
2P  ) 

1350  FORMAT  ( 14 , 17 , E18 . 6 , E12 . 6 , 14 , 14 , 15 , E12 . 6 , E12 . 6 , E12 . 6 , E12 .6 , E12 . 6 
1  , E12 .6) 

1330  FORMAT  ( 16H  ENERGY  OF  ATOM- , El 2 . 6 , 2X , 29HENERGY  WITH  ELECTRON  REMOV 
1ED-.E12.6.2X, 6HEDGEC- , E 1 2 . 6 , 2X . 1 5HAT0M  SCREENING- , E 1 2 . 6 ) 

1370  FORMAT  (34H  CROSS-SECTION  FOR  ENERGY  INTERVAL , 13 , 3HIS  , El 1.3) 

END 
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‘DECK  PE 

SUBROUTINE  PE 
•IF  DEF.B32 

IMPLICIT  DOUBLEPRECIS ION(A-H.O-Z) 

•ENDIF 
•CALL  BLANK 
•CALL  EQVP 
•CALL  EQFL 
•CALL  INDX 
•CALL  PEPT 

ENU-1 . /V( J)/RHO(M) 

IF  (ENU.LT.l.)  GO  TO  30 
ES1-0.0 
C 

C  MATERIAL  IS  COMPRESSED. 

C 

EMU -ENU-1 . 

IF  (CUSPA(M) . EQ.O. )  GO  TO  10 
ARG-EMU-CUSPA(M) 

IF  (ARG.LE.O.)  GO  TO  10 

PH-(CUSP1 (M)+( (CUSPS(M) *ARG+CUSPD(M) ) *ARG+CUSPC(M) ) *ARG) 
GO  TO  20 

1 0  PH- ( C  EQSTS ( M ) • EMU+EQSTD( M ) ) *EMU+EQSTC(M ) ) • EMU 
20  CONTINUE 

ES 10-FL0AT ( N ATOMC  M ) ) / XMV ( M ) 

DEDT-1 ,25E8*(2.+3. *ZFM( J) ) *ES10 

DPDT-8 . 31E7* ( 3 . *EQSTG(M)+2 . *ZFM( J) ) *ES10/V( J) 

TREF-300 . 

PH-PH* ( 1 . - . 5 • EQSTGC M ) • EMU/ ENU ) 

EH-- -5*PH*  C V( J)-l . /RHO(M) ) 

ENTRY  PEI 

DFDT- ( TEMP J-TREF ) *  ES10 

ET(J)-EI(J)+2.5E8«(1.+.5*ZFM(J))*TEMPJ*ES10+EH 
PN(J)-PH+8 .31E7*C3. • EQSTGC M)+ZFM( J) ) *DFDT/ V( J) 

I  GO-1 
GO  TO  80 
C 

C  MATERIAL  IS  EXPANDED 
C 

30  CONTINUE 
Vl-1 ./ENU 

ENU2«EQSTN(M) * (1.-V1)*V1 
IF  (ENU2.LE.-10.)  GO  TO  40 
ESI -EQSTE (M) • ( 1 . -EXP ( ENU2 ) ) 

GO  TO  50 
40  ESl-EQSTE(M) 

50  ALF-EQSTH(M)+(EQSTG(M)-EQSTH(M) ) ’SQRT(ENU) 

IF  ( ABS( ALF-EQSTH(M) ) . GT . 1 . E-3)  GO  TO  60 
Wl-1.0 
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GO  TO  70 

60  Wl«2 . * (EQSTG(M)-ALF) / ( ALF-EQSTH(M) ) 
WI-(2.+Wl)/(l.+Wl) 

70  CONTINUE 

ES 1 O-FLOATC NATOM (M) )/ XMW ( M ) 

DEDT*1 . 25E8* ( Wl+3 . *2FM( J) ) *ES10 

DPDT*8 . 31E7* ( 1 . 5*ALF*Wl+2 . *ZFM( J ) ) *ES10/V( J) 

TREF-ES1/ ( 1 . 25E8  *ES10* ( W1+ . 5*ZFM( J) ) ) 

’IF  DEF.B64 

TREF-AMAX1 ( TREF , 300 . ) 

*ENDIF 
’IF  DEF.B32 

TREF -DMAX1 (TREF , 3 . D2) 

’ENDIF 

ENTRY  PE2 

DFDT- ( TEMP J-TREF ) *  ES 1 0 

ET(J)-EI(J)+1.25E8*ES10*TEMPJ*(V1+ZFM( J)) 
PN(J)-8.31E7*(1 .5*ALF*W1+ZFM( J) ) *DFDT/V( J) 

I  GO -2 

80  CONTINUE 
RETURN 
C 

END 
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‘DECK  PLOT 

SUBROUTINE  PLOT 
‘IF  DEF.B32 

IMPLICIT  DOUBLEPRECISION ( A-H , O-Z ) 

‘ENDIF 

C 

‘CALL  ELANK 
•CALL  PLOTCM 

DATA  IFEDIT.  IJEDIT  /1.0/ 

C 

WRITE  (2)  (DISCPTCI) ,1-1 ,8) 

DO  10  I - 1 , NMTRLS 
JBND( I) -25*1+1 
10  CONTINUE 

J3ND( NMTRLS ) - JSTAR-1 
PPMAX-0 . 

PPMIN-O. 

WRITE  (6,80) 

WRITE  (6,90) 

DO  20  J-l.JSTAR 
PSMAX ( J ) -PSMAX ( J ) » 1 . E-9 
PSMIN( J)-PSMIN( J) *  1 .E-9 
•IF  DEF.B64 

PPMAX-AMAX1 ( PSMAX( J) , PPMAX) 

PPMIN -AMIN 1 ( PSMIN( J) , PPMIN) 

‘ENDIF 
•IF  DEF.B32 

PPMAX-DMAX1 ( PSMAX( J) , PPMAX) 

PPMIN-DMIN1 ( PSMIN( J) . PPMIN) 

‘ENDIF 

WRITE  (6,100)  PX(J) ,PSMAX(J) ,PSMIN(J) 

20  CONTINUE 

JSTAR- JSTAR-1 

WRITE  (2)  JSTAR, NMTRLS, (JBND( I), I -1, NMTRLS), PPMIN. PPMAX 
WRITE  (2)  (PX( J) ,PSMAX(J) ,PSMIN( J) , J-l .JSTAR) 

IF  (NJEDIT.GT.O)  GO  TO  30 
M-0 

NJEDIT-1 

WRITE  (2)  M , I JEDIT .NJEDIT , MTLN( 1 ) ,DSTF( 1 ) , JEDIT( 1 ) ,MM( 1 ) 
RETURN 
30  CONTINUE 
REWIND  8 

DO  40  I -1, NJEDIT 
JJ-MTLN(I) 

MM ( I ) -MATL( J J ) 

40  CONTINUE 
N-N-l 

IF  ( IFEDIT. GT.C)  WRITE  (6,110) 

WRITE  (2)  N , I JEDIT .NJEDIT , (MTLN( I ) , DSTF( I ) , JEDIT( I ) , MM( I ) , 1-1 
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1  .NJEDIT) 

ABsl  E— 9 

IF  (IJEDIT.GT.O)  AB-l.E-6 
DO  70  L-l.N 

READ  (8. 120, END-50)  TIME ,( SQJ( I ), 1-1 .NJEDIT) 

50  TIME-TIME* 1 .E+6 
DO  60  1-1, NJEDIT 
SQ J ( I  )  -SQ  J C  I  )  *  AB 
60  CONTINUE 

WRITE  (2)  TIME, (SQJ(LL) ,LL-1 .NJEDIT) 

IF  (IFEDIT.GT.O)  WRITE  (6,120)  TIME ,( SQJ( I ), 1-1 .NJEDIT) 

70  CONTINUE 
REWIND  2 
RETURN 

80  FORMAT  ( 1H1 , / / , 10X , 37HPEAX  COMPRESSIVE  AND  TENSILE  ENVELOPE/) 
90  FORMAT  ( 12X , 5HX(CM) ,6X . 8HSMAXCKB) ,4X , 8HSMINCKB) , / ) 

100  FORMAT  (9X , 3( 1PE10 . 3 , 2Z) ) 

110  FORMAT  (1H1 . 10X . 11HJEDIT  PRINT,/) 

120  FORMAT  (B2 . 3X, 1P1 1E12 .4/ ) 

END 
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•DECK  PT 

SUBROUTINE  PT 
•IF  DEF.B32 

IMPLICIT  DOUBLEPRECI SION ( A-H , O-Z ) 

•ENDIF 
•CALL  BLANK 
•CALL  EQVP 
•CALL  EQFL 
•CALL  INDX 
•CALL  PEPT 
M-l 

DO  170  J-2.J1 

IF  (J-l .EQ. JBND(M))  M-M+l 

NTMP-NELEM(M)-1 

NTMP -MAXO ( NTMP , 1 ) 

ZFM(J)«ZFM(J)/FLOAT(NATOM(M)) 

IF  ( I FLOW . EQ . 0 . AND . ITER( J ) . EQ . 0 )  GO  TO  160 

IF  ( ITER(  J-l )  .EQ .  0 .  AND .  ITER(  J)  .EQ .  0  .AND.  ITER( J+l )  .  EQ  ■  0)  GO  TO  160 
TEMP J -TEMP ( J ) 

I COUNT- 1 
TMIN-0 . 

TMAX-1.E40 

FTNE1--E( J)-EADD( J)+0 . 5*P( J) *DV( J)-0 . 5* (FO( J)-FO( J-l ) ) * (DTN-DTNH) 
1  /ZM( J) 

ITER(J)-4 

IF  (IDIF.EQ.O)  ITER(J)-1 
IF  (ICON.EQ.O)  ITER( J)-2 
IF  (ICON.EQ.O. AND. IDIF.EQ.O)  ITER(J)-3 
CALL  PE 
GO  TO  30 
10  CALL  PEI 
GO  TO  30 
20  CALL  PE2 
30  CONTINUE 
C 

C  FTNEW  IS  THE  ENERGY  IMBALANCE  CAUSED  BY  USE  OF  INCORRECT  TEMP. 

C 

FTNEV -FTNE 1 +ET( J)+0.5*PN(J)*DV(J) 

IF  (IFLOW.EQ.O)  GO  TO  70 
FTMP-0 . 0 
F( J)-0 . 0 

IF  (J.EQ.JFIN)  GO  TO  60 
IF  (ITER(J) .EQ. 1)  GO  TO  40 

F( J)-2 . 0*XC0N(M)/ ( X(J+1)-X(J-1)) * (TEMP( J+l )-TEMPJ) 

40  IF  (ZFM( J) .LT. 0.01 .AND. ZFM( J+l) .LT. 0.01)  GO  TO  50 
XLTP1 -XLAM1 ( J) * (TEMP( J)/TEMPJ ) *  *0 . 5 
ARGEXP -TEMP J / TEMP ( J ) 

ARGTST-10 .••(100./(3 . 5 ’FLOAT (NTMP) ) ) 

*IF  DEF.B64 
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ARGEXP - AM I N 1 ( ARGEXP , ARGTST ) 

•ENDIF 
•IF  DEF.B32 

ARGEXP.DMIN1 ( ARGEXP , ARGTST) 

•ENDIF  ' 

XLTPJ?-XLAK2  ( J  )  *  ARGEXP  ••(3.5*  FLOAT  (  NTMP  )  ) 

IF  ( XLTP2/ (X(J)-X(J-1)).GT.5 .67E-5 )  XLTP2-5 .67E-5*(X( J)-X( J-l) ) 
XLTP3-XLAM2CJ+I) 

IF  (XLTP3/(X( J+1)-X(J)) .GT.5.67E-5)  XLTP3-5 .67E-5* (X( J+l )-X( J) ) 
FTMP«(XLAM1( J+l )+XLTP3+XLTPl+XLTP2)/ (X( J+l )-X( J-l ) ) * (TEMP( J+l ) • *4 
1  -TEMP J* *4) 

F( J)-F(J)+FTMP 
50  IF  (J.NE.2)  GO  TO  70 
60  FTMP1«5.67E-5*TEMPJ**4 
IF  (J.EQ.2)  F( J-l )«FTMP1 
IF  (J.EQ.JFIN)  F(J)— FTMP1 
70  FTMP«F(J)-F(J-1) 

C 

C  TNEW  IS  THE  NEW  GUESS  AT  A  TEMPERATURE 
C 

FTNEW-FTNEV-0 . 5*FTMP*DTNH/ZM( J) 

IF  (ICOUNT.NE.l)  GO  TO  80 
SAVEl-ET(J) 

SAVE2-PNCJ) 

SAVE3-FTNEW 

FSAVEl-F(J) 

FSAVE2-FCJ-1) 

80  TNEW-TEMPJ-FTNEW/ (DEDT+O . 5*DV( J ) *DPDT) 

IF  ( KPRIN . NE . 0 . AND . J . EQ . JTS )  WRITE  (6,180)  J , FTNE1 , ET( J) ,DV( J) , PN 

1  (J) , DEDT , DPDT , DFDT.TEMPJ ,TNEW , FTNEW , XLAM1 ( J) , XLAM2( J ),F(J),F(J-1) 

2  , F0( J) ,F0( J-l) ,DTNH, ZM( J) ,TMIN , TMAX 
•IF  DEF.B64 

IF  (ABS(TNEW-TEMPJ) .LE . AMAX1 (DTMIN* (TNEW-300 . 0)/2 . 0 , 1 .E-7))  GO  TO 
1  120 
•ENDIF 
•IF  DEF.B32 

IF  ( ABS(TNEW-TEMPJ ) . LE . DMAX1 (DTMIN* (TNEW-300 . 0) /2 . 0 , 1 . D-7 ) )  GO  TO 
1  120 
*  ENDIF 

IF  (TNEW.LT.TEMPJ)  GO  TO  90 
IF  (TEMPJ.GT.TMIN)  TMIN-TEMPJ 
IF  (TNEW.GT.TMAX)  TNEW-TMAX 
GO  TO  100 

90  IF  (TEMPJ.LT. TMAX)  TMAX-TEMPJ 
IF  (TNEW.LT.TMIN)  TNEW-TMIN 
100  TEMP J "0 . E  * ( TEMP J +TNEW ) 

I COUNT ■ I COUNT + 1 

IF  ( ICOUNT . LE . 500 )  GO  TO  110 

WRITE  (6,190)  J 

JTS-J 
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WRITE  (6,180)  J , FTNE1 , ETC J ) , DV( J ) , PN( J) , DEDT , DPDT , DFDT , TEMP J , TNEW 

1  , FTNEW, XLAM1 (J) , XLAM2C J) ,F(J),F(J-1), FO( J) ,FO( J-l ) ,DTNH, ZM( J ) 

2  . TMIN.TMAX 

JCYCS -MIN0 (  N+ 5 . JCYCS ) 

GO  TO  160 
110  CONTINUE 

GO  TO  (10,20),  IGO 
CALL  GOTOER 
120  TEMPOC J) -TEMP (J) 

IF  (TEMPJ  .GT  .  1 . 2E4.0R.EK  J)  .  GT  .  1 .  E-10)  GO  TO  130 

ITER(J)«0 

TEMP(J) -TEMPJ 

ET( J) -ETC J ) -FTNEW 

GO  TO  160 

130  IF  ( ABS(TEMPJ-TEMP( J) )-DTMIN* (TEMP( J)-300 . 0) )  140,140,150 
140  ITER( J)-0 

ET(J)-SAVE1-SAVE3 

PN(J)-SAVE2 

IF  (IFLOW.EQ.O)  GO  TO  160 
F( J)-FSAVE1 
F( J-l )-FSAVE2 
GO  TO  160 

150  TEMP( J)-0 .9*T2MP( J)+0 . 1 *TNEW 

IF  (TEMP( J) .GT. 1 ,20*TEMPO( J))  TEMP( J)-l ,20*TEMPO( J ) 

IF  (TEMP(J).LT. TEMPOC J)/l. 20)  TEMPCJ)-TEMP0(J)/1 .20 
160  IF  (ITER(J).EQ.O)  JCOUNT-JCOUNT+1 
ZFM( J)-ZFM( J) *FLOAT(NATOM(M) ) 

170  CONTINUE 
RETURN 

180  FORMAT  (6X , 1HJ , 7X , 5HFTNE1 , 10X , 2HET , 10X , 2HDT, 10X . 2HPN , 8X .4HDEDT , 8X , 

1  4HDPDT , 8X , 4HDFDT , 7X , 5HTEMPJ , 8X , 4HTNEW/4X , 13 , 1P9E12 . 4/ / 14X , 5HFTNEW 

2  , 7X , 5HXLAM 1 , 7X , 5HXLAM2 , 8  X , 4HF ( J ) , 6X , 6HF (J-l) ,7X, 5HF0 ( J) , 5X, 7HF0 ( J 
3-1 ) , 8X , 4HDTNH , 10X . 2HZM/7X , 1P9E12 . 4/ / 15X , 4HTMIN , 8X . 4HTMAX/7X . 1 P2E12 

4  .4///) 

19C  FORMAT  (10H  J  EQUALS  , 110 , 5X, 17HHAS  NOT  CONVERGED) 

END 
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•DECK  REZONE 

SUBROUTINE  REZONE 
*  IF  DEF.B32 

IMPLICIT  DOUBLEPRECI SION ( A-H , O-Z ) 

•ENDIF 

C 

C  HYPUF  REZONING  ROUTINE 

C 

•CALL  BLANK 
•CALL  EQVP 
•CALL  PLOTCM 
•CALL  RZCOM 
•CALL  SPLLC 

DIMENSION  ZFR(IO),  ZFL(IO),  SSR(IO),  SSL(IO) 

DATA  JDBG  /0/ 

C 

C  LOOP  OVER  MESH 

C 

WTAPE-0 . 0 

IF  (JDBG.EQ.l)  CALL  EDIT 

JJPRIN-3 

M-l 

J-2 

JJPRIN-J 

SMAX-ABS(SMAX) 

10  AAA-ABS(S(J)-RZC1) 

IF  (JDBG.EQ.l)  WRITE  (6,660)  JFIN 
AAA  « AAA/  SMAX 

IF  ( J-l . EQ . JBND(M) )  M-M+l 
IF  (J.GE.200)  GO  TO  600 
IF  (J.GE.JFIN)  GO  TO  600 
ARZCO-AAA  *RZCO 
•IF  DEF.B64 

SLIM-AMAX1 ( RSCRIT , ARZCO) 

•ENDIF 
•IF  DEF.B32 

SLIM-DMAX1 ( RSCRIT , ARZCO ) 

•ENDIF 

DELS-(S( J+l)-S( J))/SMAX 
ADELS -AES (DELS) 

IF  ( JFIN. GE. 200)  GO  TO  20 
IF  (J.GT.JSTAR)  GO  TO  600 
C 

JF-0 

IF  (JDBG.EQ.l)  WRITE  (6,670)  J 

IF  (JDBG.EQ.l)  WRITE  (6,680)  AAA , ARZCO , SLIM , DELS , ADELS , S( J) , SMAX 
C 

C  CHECK  FOR  DIVIDE 

C 
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IF  C ADELS. GT. SLIM)  GO  TO  30 
CHECK  FOR  COMBINE 
20  CONTINUE 

IF  (ADELS.LT. (0.2*SLIM))  GO  TO  410 
cJ  “«J+1 

IF  (J.LT.JFIN)  GO  TO  10 
GO  TO  600 

DIVIDE  LOOP 

30  AU-ABS(UCJ)) 

DISTRZ- . 5*DTNH*CS( J ) *NREZ0N*U( J)/AU 

IF  (JDBG.EQ.l)  WRITE  (6,690)  DISTRZ , DTNH , CS( J) .NRE20N , U( J) . AU 

IF  (DISTRZ. GT. 0.0)  GO  TO  60 

DO  40  LJ-l.J 

LM1-LJ-1 

DELX-X(LJ)-X( J) 

IF  (DELX.LT. DISTRZ)  GO  TO  50 
40  CONTINUE 
50  JF «MAX0( 1 , LM1 ) 

GO  TO  250 
60  DO  70  LJ-J.JFIN 

DELX»ABS(X(LJ)-X( J) ) 

IF  (DELX.GE. DISTRZ)  GO  TO  80 
IF  (JDBG.EQ.l)  WRITE  (6,700)  J , LJ , JFIN . DELX 
70  CONTINUE 

80  NRZ1-LJ-J 

NRZ2-NRZ1 *(1.1*  *NRZ1 ) 

JF-MINO( J+NRZ2 , JFIN) 

REZONE  TO  RIGHT  . . . 

Jl-J 

DO  240  LJ-J1.JF.2 

LM1-LJ-1 

LP1-LJ+1 

IF  (JDBG.EQ.l)  WRITE  (6,710)  J.JF.LJ 
ZMT«2 . 0*ZM(LJ ) 

IF  (ZM(LMl) .GE.ZMT)  GO  TO  230 
IF  (ZM(LPl). GE.ZMT)  GO  TO  230 
XL-(X(LJ)+X(LMl))/2.0 
XR-X(LJ) 

DELX-X(LJ)-X(LM1) 

XMIN-1 .E-8*CS(LJ) 

IF  (DELX.LE.XMIN)  GO  TO  230 

CHECK  FOR  MATERIAL  BOUNDRIES 
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C 

DO  90  LM-l.NMTRLS 
IF  (LJ.EQ. JBND(LM))  GO  TO  110 
IF  ((LM1) .EQ. JBND(LM))  GO  TO  100 
90  CONTINUE 

IF  (TSPALL(LJ) .EQ.l .234)  GO  TO  240 
IF  (TSPALL(LJ) .EQ.O. )  GO  TO  100 
IF  (TSPALL(LHl) . EQ . 1 .234)  GO  TO  100 
IF  (TSPALL(LMl) .NE.TSPALL(LJ))  GO  TO  100 
IF  (TSPALL(LJ) .NE.TSPALL(LPl))  GO  TO  110 
C 

C  DIVIDE  INTERNAL  ZONE 
C 

RZRL«(ZM(LM1)+ZM(LJ))/(ZM(LM1)+ZM(LJ)+ZM(LP1)) 

RZRR-1 .O-RZRL 
L1-LP1 
L2-LP1 
L3-LM1 
L4-LM1 
GO  TO  120 
C 

C  DIVIDE  ZONE  WITH  MATERIAL  BOUNDRY  AT  LEFT  INTERFACE  . . . 

C 

100  CONTINUE 

RZRR-(0.5*ZM(LJ)+ZM(LP1))/(ZM(LJ)+ZM(LP1)) 

RZRL-1 . -RZRR 
L1-LP1 
L2-LP1 
L3-LJ 
L4-LP1 
GO  TO  120 
C 

C  DIVIDE  ZONE  WITH  MATERIAL  BOUNDRY  AT  RIGHT  INTERFACE  . . . 

C 

110  CONTINUE 

RZRL«( ZM(LM1 )+0 . 5*ZM(LJ ) ) / ( ZM(LM1 )+ZM(LJ ) ) 

RZRR-1 . -RZRL 
LI  — L<J 
L2-LM1 
L3-LM1 
L4-LM1 

120  CONTINUE 

ZMR-0 . 5  *  ZM( LJ ) 

ZML-ZMR 

UR-U(LJ) 

UL-C  ZMR*U( LM1 )  +  ZML*U(LJ ) ) /ZM( LJ ) 

C 

IF  (JDBG.EQ.l)  WRITE  (6,720)  DR , DL , V(LM1 ) , V( LJ ) , V( LP1 ) , ZMR , ZML . ZM 
1  (LJ) 

SR«S(L1 )*RZRR* ( S(LJ)-S(L2) ) 
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SL-S(L3)+RZRL*(S(LJ)-S(L4)) 

SDR-SDC  LI ) +RZRR* ( SD( LJ ) -SD( L2 ) ) 
SDL-SD( L3 ) +RZRL* ( SD( LJ ) -SD(  L4  ) ) 
SD2R-SD2 (LI) +RZRR * ( SD2 ( LJ ) -SD2 ( L2 ) ) 
SD2L- SD2 ( L3 ) +RZRL * ( SD2 ( LJ ) - SD2 ( L4 ) ) 
QUR-QU ( LI ) +RZRR  *(QU(LJ)-QU(L2) ) 
QUL-QU ( L3 ) +RZRL * (QU(LJ)-QU(L4) ) 

•IF  DEF.B64 

QUR-AMAX1 ( OUR , 0 . ) 

QUL-AMAX1 ( QUL , 0 . ) 

•ENDIF 
•IF  DEF.B32 

QUR-DMAX1 ( QUR , 0 . DO ) 

QUL-DMAX1 ( QUL , 0 . DO ) 

•ENDIF 

YYR-YY(Ll)-rRZRR*(YY(LJ)-YY(L2)) 

YYL- YY ( L3 ) +RZRL * ( YY ( LJ ) - YY ( L4 ) ) 
ZZR*ZZ(L1 )+RZRR* ( ZZ(LJ)-ZZ(L2) ) 
ZZL-ZZ ( L3 ) +RZRL * ( ZZ ( LJ ) - ZZ ( L4 ) ) 
VAMUR-VAMU(LJ) 

QR-QCLl )+RZRR* (Q(LJ)-Q(L2) ) 
QL-Q(L3)+RZRL*(Q(LJ)-Q(L4)) 

•IF  DEF.B64 

QR«AMAX1(QR,0.0) 

QL-AMAX1 (QL ,0.0) 

•ENDIF 
•IF  DEF.B32 

QR-DMAXl(QR.O.DO) 

QL-DMAXl(QL.O.DO) 

•ENDIF 

VR-V(LJ) 

VL-VR 

DVR-DV ( LI ) +RZRR* ( DV( LJ ) -DV( L2 ) ) 

DVL -DV ( L3 ) +RZRL  * ( DV ( L J ) -DV ( L4 ) ) 
CSR-CS(Ll)-rRZRR*(CS(LJ)-CS(L2)) 
CSL-CS ( L3 ) +RZRL * ( CS ( L J ) -CS ( L4 ) ) 
CSR-ABS(CSR) 

CSL-ABS(CSL) 

Q0R-Q0(L1)+RZRR*(Q0(LJ)-Q0(L2)) 

QOL-QO(L3)+RZRL*(QO(LJ)-QO(L4)) 

•IF  DEF.B64 

Q0R-AMAX1 ( QOR , 0 . ) 

Q0L-AMAX1 ( QOL , 0 . ) 

•ENDIF 
•IF  DEF.B32 

Q0R-DMAX1 ( QOR , 0 . DO) 

Q0L-DKAX1 ( QOL . 0 . DO) 

•ENDIF 

YQZR-Y0Z(L1  )-rRZRR*  (Y0Z(LJ)-Y0Z(L2)  ) 
YOZL=YOZ( L3)+RZRL* ( YOZ( LJ )-YOZ(  L4 ) ) 
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ER«E(L1)+RZRR*(E(LJ)-E(L2)) 

EL-£(L3)+RZRL*(E(LJ)-E(L4)) 

EL-ABS(EL) 

ER-ABS(ER) 

DE-E(LJ)*ZM(LJ)/(ER*ZMR+EL*ZML) 

ER-ER*DE 
EL-EL *DE 

EADDR-EADD( LI ) +RZRR* ( EADD( LJ ) -EADD( L2 ) ) 

EADDL-EADDC L3 ) +RZRL * ( EADD( LJ ) -EADD( L4 ) ) 

EADDL-ABS ( EADDL ) 

EADDR - ABS ( EADDR ) 

DE— 0 . 0 

IF  (EADD(LJ) .NE.O.O)  DE - EADD (  L  J  )  *  ZM  ( LJ ) / ( EADDR  *  ZMR+EADDL  *  ZML ) 

EADDR- EADDR *  DE 

EADDL-EADDL*DE 

PR-P(L1 )+RZRR* ( P(LJ)-P(L2 ) ) 

PL-P(L3)+RZRL*(P(LJ)-P(L4) ) 

PSMAXR-PSMAX ( LI ) +RZRR * ( PSMAX ( L J ) -PSMAX C L2 ) ) 

PSMAXL»PSMAX(L3 ) +RZRL * ( PSHAX( LJ) -PSMAXC  L4 ) ) 

PSMINR-PSMIN(  LI  )  -t-RZRR  «  (  PSMIH(  LJ)  -PSMINC L2 )  ) 

PSMINL-PSMIN C L3 ) +RZRL • ( PSMIN ( LJ) -PSMINC L4 ) ) 

PXR-PX(LJ) 

PXL-0 . 5* (PX(LM1 )+PXR) 

TEMPR-TEMP (LI) +RZRR • ( TEMP ( L J ) -TEMP( L2 ) ) 

TEMPL-TEMP ( L3 ) +RZRL •< TEMP ( LJ ) -TEMP (  L4  )  ) 

TSPLLR-TSPALL(LJ) 

TSPLLL-TSPLLR 

ZFMR-ZFM(L1 ) +RZRR* ( ZFM( LJ ) -ZFM( L2 ) ) 

ZFML-ZFM ( L3 ) +RZRL » ( ZFM( LJ ) -ZFM( L4 ) ) 

EIR-EI (LI )+RZRR* (EI(LJ)-EI (L2) ) 

EIL«EI(L3)+RZRL* (El (LJ)-EI (L4) ) 

EIL-ABS(EIL) 

EIR-ABS(EIR) 

DE-0 . 0 

IF  (EI(LJ). NE.O.O)  DE-EI(LJ) *ZM(LJ)/ (EIR*ZKR+EIL*ZML) 

EIR-EIR*DE 

EIL-EIL*DE 

FR-F(H)4-RZRR*(F(LJ)-F(L2)) 

FL-F ( L3 ) +RZRL  * ( F ( L J ) -F ( L4 ) ) 

FOR-FO( LI ) *RZRR* ( FO( LJ ) -FO( L2 ) ) 

FOL-FO (  L3  )  -*-RZRL  *  (  FO  (  L J  )  - FO  ( L4  )  ) 

NEL-NELEM(M) 


DO  130  NN-i.NEL 

ZFR(NN) -ZF(NN , LI )+RZRR* ( ZF(NN . LJ)-ZF( NN . L2) ) 
ZFL(NN ) «ZF(NN , L3)+RZRL* ( ZF(NN , LJ) -ZF( NN , L4) ) 
130  CONTINUE 

DO  140  LL-l.NSPEC 

SSR(LL)-SS(L1 , LL)+RZRR* ( SS(LJ , LL)-SS(L2 , LL) ) 
SSL( LL)-SS(L3 , LL)+RZRL* ( SS ( LJ , LL)-SS(L4 , LL) ) 
140  CONTINUE 
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IF  (JDBG.EQ.l)  WRITE  (6,730)  RZRL , RZRR ,  XL ,  XR ,  UL ,  UR , TSPLLL , TSPLLR 

SHIFT  ZONAL  PROPERTIES  TO  CORRESPOND  TO  NEW  MESH 

JJJJ-JFIN-LJ 
DO  170  JJJ-l.JJJJ 
JJ-JFIN-JJJ+1 

IF  (JDBG.EQ.l)  WRITE  (6,650)  JJ 
X( JJ+1)-X(JJ) 

U( JJ+1)-U(JJ) 

ZM( JJ+1)«ZM(JJ) 

S( JJ+1)-S( JJ) 

SD( JJ+1)-SD(JJ) 

SD2(JJ+1)«SD2( JJ) 

QU( JJ+1)-QU(JJ) 

TY( JJ+1 )-TY( JJ ) 

VAMU ( J J+ 1 ) - V AMU ( J J ) 

ZZ(JJ+1)-ZZ(JJ) 

Q( JJ+1)-Q(JJ) 

V( JJ+1 )-V( JJ) 

DV(JJ+1)-DV(JJ) 

CS(JJ+1)-CS(JJ) 

QO(JJ+l)-QO(JJ) 

YOZ( JJ+1 )«T0Z( JJ) 

E(JJ+1)-E(JJ) 

EADD( JJ+1) -EADD( J J ) 

P(JJ+1)-P(JJ) 

PSMAX ( JJ+ 1 ) - PSMAX ( J J ) 

PSMIN( JJ+1 )»PSMIN( JJ) 

PX(JJ+1)-PX(JJ) 

TEMP (JJ+1 ) -TEMP ( J J ) 

TSPALL( JJ+1 )-TSPALL( JJ) 

ZFM( JJ+1 )-ZFM( JJ) 

El (JJ+1 )-EI( JJ ) 

F( JJ+1 )-F( JJ) 

FO( JJ+1 )-FO( JJ ) 

NEL-NELEM(M) 

DO  150  NN-1 ,NEL 
ZF(NN , JJ+1 )-ZF(NN , JJ) 

150  CONTINUE 

DO  160  LL-1 , NSPEC 
SS( JJ+1 , LL )-SS( JJ , LL) 

160  CONTINUE 
170  CONTINUE 

INPUT  PROPERTIES  OF  NEW  ZONES  INTO  THE  NEW  MESH 

X(LP1 )-XR 
X(LJ)-XL 

IF  (JDBG.EQ.l)  WRITE  (6,790)  LJ , X( LJ) , X(LP1 ) 
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U(LP1)-UR 

U(LJ)-UL 

ZM(LP1)-ZMR 

ZM(LJ)-ZML 

S(LP1)«SR 

S(LJ)-SL 

SDCLP1)-SDR 

SD(LJ)-SDL 

SD2  C  LP 1 ) »SD2R 

SD2  C  L J ) «SD2L 

QU(LP1)-QUR 

QU(LJ)-QUL 

VAMU(LP1)-VAMUR 

VAMU(LJ)-VAMUR 

YY(LP1)-YYR 

YY(LJ)-YYL 

ZZ(LP1)-ZZR 

ZZ(LJ)-ZZL 

QCLPD-QR 

Q(LJ)-QL 

VCLPD-VR 

V(LJ)-VL 

DV ( LP 1 ) -DVR 

DV(LJ)-DVL 

CS(LPI)-CSR 

CS(LJ)-CSL 

QO(LPl)-QOR 

QO(LJ)-QOL 

YOZCLPl)-YOZR 

YOZ(LJ)-YOZL 

E(LP1)-ER 

E(LJ)«EL 

EADD( LP 1 ) -EADDR 

EAODC  LJ ) »E ADDL 

P(LP1)-PR 

P(LJ)-PL 

PSMAX C LP I ) - PSMAXR 

PSMAX(LJ)«PSMAXL 

PSMIN(LP1)-PSMINR 

PSMIN(LJ)-PSMINL 

PX(LP1)-PXR 

PX(Lc J-PXL 

TEMP ( LP 1 ) «TEMPR 

TEMP(LJ)-TEMPL 

TS  PALL ( LP 1 ) -TS PLLR 

TSPALLC  LJ ) -TSPLLL 

ZFM ( LP 1 ) *  ZFMR 

ZFM(LJ)«ZFML 

EICLPD-EIR 

EI(LJ)-EIL 
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F(LP1)-FR 

F(LJ)«FL 

FO(LPl)-FOR 

FO(LJ)-FOL 

NEL-NELEM(M) 

DO  180  NN-l.NEL 
ZF(NN,LP1)-ZFR(NN) 

ZF(NN,LJ)-ZFL(NN) 

180  CONTINUE 

DO  190  LL-1 .NSPEC 
SS( LP1 .LL)-SSR(LL) 

SS(LJ,LL)-SSL(LL) 

190  CONTINUE 

DO  200  LM-l.NMTRLS 

IF  ( JDBG . EQ . 1 )  WRITE  (6,740)  J ,LJ , JBND(LM) 

IF  (LJ.GT. JBND(LM))  GO  TO  200 
JBND(LM) -JBND( LM)+1 

IF  (JDBG.EQ.l)  WRITE  (6,740)  J ,LJ , JBND(LM) 
200  CONTINUE 

IF  (NJEDIT.EQ.O)  GO  TO  220 
DO  210  LL-l.NJEDIT 
IF  (LJ.GT. JEDIT(LL))  GO  TO  210 
JEDIT(LL)«JEDIT(LL)+1 
210  CONTINUE 
220  CONTINUE 

IF  (LM1 .LE. JHAT)  JHAT-JHAT+1 
IF  (LM1 .LE.JSMAX)  JSMAX- JSMAX+1 
IF  (LM1 .LE.JSTAR)  JSTAR-JSTAR+1 
IF  (LM1.LE.JTS)  JTS-JTS+1 
JFIN-JFIN+1 

IF  (JFIN.GE.200)  GO  TO  600 
J-J+l 

230  CONTINUE 
J-J+l 

IF  (J.GE.JFIN)  GO  TO  600 
240  CONTINUE 
J-J+l 
JJPRIN-J 
GO  TO  10 

REZONE  TO  LEFT  OF  GRADIENT  (DIVIDE  ZONES) 

250  CONTINUE 

JF -MAXO ( JF , JJPRIN ) 

JJJ-J-l-JF 

LL-1 

IF  (JDBG.EQ.l)  WRITE  (6,750)  J,JF 
DO  400  LLL-l.JJJ 
LJ- J-LLL+1 
LM1-LJ-1 
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LP1-LJ+1 

ZMT-2.0*ZM(LJ) 

IP  CZM(LMl) .GE.ZMT)  GO  TO  400 
IP  (ZM(LPl) .GE.ZMT)  GO  TO  400 
IF  (JDBG.EQ.l)  WRITE  (6,760)  L J 
IF  (LJ.LT. JJPRIN)  GO  TO  400 
XMIN-1 .  E-8*CS(LJ) 

DELX-X(LJ)-XCLMl) 

IF  (DELX.LE.XMIN)  GO  TO  400 

XL«(X(LJ)+X(LMl))/2.0 

XR-X(LJ) 

CHECK  FOR  MATERIAL  BOUNDRIES  . . . 

DO  260  LM-l.NMTRLS 

IF  (JDBG.EQ.l)  WRITE  (6,770)  LJ.JBND(LM) 

IF  (LJ.EQ. JBND(LM))  GO  TO  280 
IF  ( (LM1 ) . EQ. JBND(LM) )  GO  TO  270 
260  CONTINUE 

IF  (TSPALL(LMl).EQ. 1.234)  GO  TO  270 
IF  (TSPALL(LJ).EQ. 1.234)  GO  TO  400 
IF  (TSPALL(LJ) . EQ.O. )  GO  TO  270 
IF  (TSPALL(LJ) .NE.TSPALL(LMl))  GO  TO  270 
IF  (TSPALL(LJ) .NE.TSPALL(LPl))  GO  TO  280 

DIVIDE  INTERNAL  ZONE 

RZRL-( XL-X(LJ-2) ) / ( XR-X(LJ-2) ) 
RZRR«(X(LP1)-XL)/(X(LP1)-X(LM1)) 

L1-LP1 
L2-LP1 
L3-LM1 
L4-LM1 
GO  TO  290 

DIVIDE  ZONE  WITH  MATERIAL  BOUNDRY  AT  LEFT  INTERFACE  . . 
270  CONTINUE 

RZRR*(X(LP1 )-XL) / ( X(LP1 ) -X(LM1 ) ) 

RZRL* 1 . -RZRR 

L1*LP1 

L2-LP1 

L3-LJ 

L4-LP1 

GO  TO  290 

DIVIDE  ZONE  WITH  MATERIAL  BOUNDRY  AT  RIGHT  INTERFACE 
280  CONTINUE 

RZRL- (  XL-X( LJ-2 )  )  /  (  XF.-X( LJ-2 )  ) 
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RZRR-1 . -RZRL 

Ll-LJ 

L2-LM1 

L3-LM1 

L4-LM1 

290  CONTINUE 

ZMR-0.5*ZM(LJ) 

ZML-ZMR 

UR-U(LJ) 

UL-(ZMR*U(LM1 )+ZML*U(LJ) )/ZM(LJ) 

C 

IF  (JDBG.EQ.l)  WRITE  (6,720)  DR , DL , V(LM1 ) ,V(LJ) , V(LP1 ) , ZMR , ZML , ZM 
1  (LJ) 

SR-S( LI )+RZRR* ( S(LJ)-S(L2) ) 

SL«S(L3)+RZRL*(S(LJ)-S(L4) ) 

SDR-SDCLl ) +RZRR* ( SD( LJ ) -SD( L2 ) ) 

SDL-SDC  L3 ) +RZRL * ( SD( LJ ) -SD( L4 ) ) 

SD2R- SD2 ( L 1 ) +RZRR * ( SD2 ( LJ ) - SD2 ( L2 ) ) 
SD2L-SD2(L3)*RZRL*(SD2(LJ)-SD2(L4)) 
QUR«QU(L1)+RZRR*(QU(LJ)-QU(L2)) 

QUL-QU ( L3 ) +RZRL * ( QU ( L J ) -QU ( L4 ) ) 

V AMUR- V AMU ( LJ ) 

*  IF  DEF , B64 

QUR-AMAX1 (QUR.O. ) 

QUL-AMAX1(QUL,0 . ) 

•ENDIF 
•IF  DEF.B32 

QUR-DMAX1C QUR.O. DO) 

QUL-DMAX1 ( QUL . 0 . DO ) 

•ENDIF 

TYR-TTCLl )+RZRR*(TT(LJ)-YY(L2)) 

TYL-TY ( L3 ) +RZRL • ( TT ( LJ ) -TT ( L4 ) ) 

ZZR»ZZ(L1 )+RZRR*(ZZ(LJ)-ZZ(L2) ) 

ZZL-ZZ(L3)+RZRL*(ZZ(LJ)-ZZ(L4)) 

QR-Q(L1)tRZRR*(Q(LJ)-Q(L2)) 

QL-QC L3 ) +RZRL* ( Q( LJ ) -Q( L4 ) ) 

•IF  DEF.B64 

QR-AMAX1 ( QR , 0 . ) 

QL-AMAX1 ( QL , 0 . ) 

•ENDIF 

*  IF  DEF.B32 

QR-DMAXHQ  , 0  .DO) 

QL-DMAXl(QL.O.DO) 

*  ENDIF 

VR-V(LJ) 

VL-VR 

DVR-DV ( LI ) +RZRR * ( DV ( LJ ) -DV ( L2 ) ) 

DVL-DVC L3 ) +RZRL • ( DV ( LJ ) -DV ( L4 ) ) 

CSR-CSCLl ) +RZRR * ( CS ( LJ ) -CS ( L2 ) ) 

CSL-CS ( L3 ) +RZRL • ( CS ( L J ) -CS ( L4 ) ) 
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CSR-ABSCCSR) 

CSL-ABSCCSL) 

QOR-QO(L1)+RZRR*CQOCLJ)-OOCL2)) 

QOL-QO ( L3 ) +RZRL * ( QO ( LJ ) -QO C L4 ) ) 

*  IF  DEF , B64 

qor-amaxicqor.o.  ) 

OOL-AMAX1CQOL.O. ) 

*ENDIF 
•IF  DEF.B32 

Q0R-DMAX1 ( QOR , 0 . DO ) 

Q0L-DMAX1 ( QOL , 0 . DO ) 

•ENDIF 

YCZR-YOZ ( LI ) +RZRR • C  YOZ ( L J ) - YOZ ( L2 ) ) 

YOZL-YOZ C L3  )  +RZRL •  ( YO Z ( L J  ) TO Z (  L4  )  ) 
ER«ECL1)+RZRR*(E(LJ)-E(L2)) 

EL«E(L3)+RZRL* ( E(LJ)-E(L4) ) 

EL-ABS(EL) 

ER-ABS(ER) 

DE-EC  LJ)  *  ZM(  LJ  )  /  (  EL  *  ZML-rER  *  ZMR) 

EL-EL’DE 

ER-ER*DE 

EADDR-EADDC  LI ) +RZRR* ( EADDC LJ ) -EADDC  L2 ) ) 

EADDL-EADDC  L3 ) +RZRL * ( EADDC  L J ) -EADDC  L4 ) ) 

EADDL-ABS C  EADDL ) 

EADDR- ABS  C  EADDR ) 

DE-0 . 0 

IF  CEADDCLJ) . NE.O.O)  DE-EADDC LJ ) * ZM C L J ) / C EADDR • ZMR+EADDL * ZML ) 
EADDL - EADDL  *DE 
EADDR - EADDR  *  DE 
PR-PCL1)+RZRR*CPCLJ)-PCL2)) 

PL-PCL3)+RZRL*CPCLJ)-PCL4)) 

PSMAXR-PSKAXCLI )+RZRR*  C  PSMAX C LJ ) -PSMAX C L2 ) ) 

PSMAXL-PSMAX C L3 ) +RZRL *  C P SMAX C  LJ ) - PSMAX C  L4 ) ) 

PSMINR-PSMINCLI )+RZRR* c  PSMINCLJ)-PSMINCL2)) 
PSMINL-PSMINCL3)+RZRL*CPSMINCLJ)-PSMINCL4)) 

PXR-PX(LJ) 

PXL-0 . 5 * C PX C LMI ) +PXR ) 

TEMPR-TEMP  C  L 1 ) +RZRR • C  TEMP  C  L J ) -TEMP  C  L2 ) ) 

TEMPL-TEMP  C  L3 ) +RZRL *  C  TEMP C  L J ) -TEMP  C  L4 ) ) 

TS  PLLR-TS  P ALL  C  L J ) 

TSPLLL-TSPLLR 

ZFMR - ZFM C  L 1 ) +RZRR  *  C  ZFM ( L J ) - ZFM ( L2 ) ) 

ZFML-ZFM C  L3 ) +RZRL • C  ZFM ( L J ) - ZFM ( L4 ) ) 

EIR-EI C  LI ) +RZRR* ( El C  LJ ) -El ( L2 ) ) 

EIL-EI(L3)+RZRL* (EI(LJ)-EIf L4) ) 

EIL-ABSCEIL) 

EIS-ABSCEIR) 

DE-0.0 

IF  CEI(LJ). NE.O.O)  DE-EI (LJ ) • ZMCLJ) / CEIR* ZMR+EIL* ZML) 
EIL-EIL*DE 
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EIR-EIR*DE 

FR-F(L1)+RZRR*(F(LJ)-F(L2)) 

FL-F(L3)+RZRL*(F(LJ)-F(L4)) 

FOR-FO ( LI ) +RZRR * ( FO ( LJ ) -FO C L2 ) ) 

FOL -FO ( L3 ) +RZRL * ( FO ( LJ ) -FO ( L4 ) ) 

NEL-NELEM(M) 

DO  300  NN-1 , NEL 

ZFR(NN)-ZF(NN,L1)+RZRR*(ZF(NN.LJ)-ZF(NN,L2)) 

ZFL(NN)-ZF(NN,L3)+RZRL*(ZF(NN,LJ)-ZF(NN,L4)) 

300  CONTINUE 

DO  310  LL-l.NSPEC 

SSR(LL)-SS(L1 , LL)+RZRR* C  SS( LJ , LL)-SS( L2 ,LL) ) 

SSL( LL) «SS( L3 , LL)+RZRL* ( SS(LJ , LL)-SS ( L4 , LL) ) 

310  CONTINUE 

IF  (JDBG.EQ.l)  WRITE  (6,730)  RZRL , RZRR , XL . XR , UL . UR , TSPLLL , TSPLLR 

SHIFT  ZONAL  PROPERTIES  TO  CORRESPOND  TO  NEW  MESH 

JJJJ.JFIN-LJ 
DO  340  JJQ-l.JJJJ 
JJ-JFIN-JJQ+1 

IF  (JDBG.EQ.l)  WRITE  (6,780)  JJ 
X(JJ+1)-X(JJ) 

U(JJ+1)-U(JJ) 

ZM(JJ+1)-ZM(JJ) 

S(JJ+1)-S(JJ) 

SD( JJ+1)«SD(JJ) 

SD2( JJ+1)-SD2(JJ) 

QU( JJ+1)-QU( JJ) 

VAMU( J J+ 1 ) -VAMU( J J ) 

YY( JJ+1)-YY(JJ) 

ZZ( JJ+1)-ZZ(JJ) 

Q( JJ+l )-Q( JJ ) 

V(JJ+1)-V(JJ) 

DV( JJ+1)-DV(JJ) 

CS( JJ+1)«CS( JJ) 

Q0( JJ+l )-Q0( JJ) 

Y0Z( JJ+l )-Y0Z( JJ) 

E( JJ+l )-E( JJ ) 

EADD( JJ+l )-EADD( JJ) 

P( JJ+l )-P( JJ ) 

PSMAX( JJ+l )-PSMAX( JJ) 

PSMIN( JJ+l ) «PSMIN( JJ ) 

PX( JJ+l )-PX( JJ) 

TEMP ( JJ+l ) -TEMP ( J J ) 

TSPALL( JJ+l )-TSPALL( JJ) 

ZFM( JJ+l )-ZFM( JJ) 

EI( JJ+l )-EI( JJ) 

F( JJ+l )-F( JJ ) 

F0( JJ+l )«F0( JJ) 
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NEL-NELEM(M) 

DO  320  NN»1 , NEL 
Z7CNN. JJ+1)-ZF(NN, JJ) 

320  CONTINUE 

DO  330  LL-l.NSPEC 
SS(JJ+1,LL)-SS(JJ,LL) 

330  CONTINUE 
340  CONTINUE 

INPUT  PROPERTIES  OF  NEW  ZONES  INTO  THE  NEW  MESH 

X(LP1)«XR 

X(LJ)-XL 

IF  (JDBG.EQ.l)  WRITE  (6,790)  LJ , X(LJ) ,X(LP1 ) 

U(LP1)-UR 

U(LJ)«UL 

ZM(LP1)«ZMR 

ZM(LJ)-ZML 

S(LP1)«SR 

S(LJ)«SL 

SD(LP1)«SDR 

SD(LJ)-SDL 

SD2(LP1 )-SD2R 

SD2 ( LJ ) -SD2L 

0U(LP1)-QUR 

QU(LJ)-QUL 

VAMU(LP1)«VAMUR 

VAMU(LJ) -VAMUR 

YY(LP1 )-YYR 

YY(LJ)-YYL 

ZZ(LP1)-ZZR 

ZZ(LJ)-ZZL 

Q(LP1)-QR 

Q(LJ)»QL 

V(LPI)-VR 

V(LJ)-VL 

DV(LP1)«DVR 

DV(LJ)-DVL 

CS( LP1 ) “CSR 

CS(LJ)-CSL 

Q0(LP1)-Q0R 

QO ( L J ) -QOL 

Y0Z(LP1)«Y0ZR 

YOZCLJ )«YOZL 

E(LP1)-ER 

E(LJ)-EL 

EADD(LP1)-EADDR 

EADD( LJ ) -EADDL 

P(LP1)-PR 

P(LJ)-PL 
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PSMAX C LP 1 ) -PSMAXR 

PSMAX( LJ ) -PSMAXL 

PSMIN(LPi)-PSMINR 

PSMIN(LJ)-PSMINL 

PX(LP1)-PXR 

PX(LJ)-PXL 

TEMP ( LP 1 ) -TEMPR 

TEMP ( L J ) -TEMPL 

TSPALLC  LP 1 ) -TSPLLR 

TSPALLC LJ ) -TSPLLL 

ZFM(LP1 )-ZFMR 

ZFM(LJ)-ZFML 

EI(LP1)-EIR 

EI(LJ)-EIL 

F(LP1)-FR 

F(LJ)«FL 

FO(LPl)«FOR 

FO(LJ)-FOL 

NEL-NELEM(M) 

DO  350  NN-1 , NEL 
ZF(NN,LP1)«ZFR(NN) 

ZF(NN,LJ)«ZFL(NN) 

350  CONTINUE 

DO  360  LL-l.NSPEC 
SS(LP1 .LL)-SSR(LL) 

SS(LJ,LL)-SSL(LL) 

360  CONTINUE 

DO  370  LM-1  ,  NMTTLLS 

IF  (JDBG.EQ.l.  WRITE  (6,740)  J ,LJ , JBND(LM) 
IF  (LJ.GT. JBND(LM))  GO  TO  370 
JBND(  LM  )  =*JBND(  LM  )+ 1 

IF  (JDBG.EQ.l)  WRITE  (6,740)  J ,LJ , JBND(LM) 
370  CONTINUE 

IF  ;NJEDIT.EQ.O)  GO  TO  390 
DO  380  LL-1 , NJEDIT 
IF  (LJ.GT. JEDIT(LL))  GO  TO  380 
JEDIT( LL ) « JEDIT( LL  ) + 1 
380  CONTINUE 
390  CONTINUE 

IF  (LJ.LE.JHAT)  JHAT-JHAT+1 
IF  (LJ.LE. JSMAX)  JSMAX-JSMAX+1 
IF  (LJ.LE. JSTAR)  JSTAR-JSTAR+1 
IF  (LJ.LE.JTS)  JTS-JTS+1 
JFIN-JFIN+1 

IF  ( JFIN.GE.200)  GO  TO  600 
LL-LLL 

IF  (JD3G.EQ.1)  WRITE  (6,800)  JFIN 
400  CONTINUE 
J«J*LL 
JJPRIN-J 
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GO  TO  10 
410  CONTINUE 

COMBINE  ZONE  IF  ZONE  J+l  IS  NOT  TOO  HEAVY 

IF  (ZM( J+l) . GE.2.0*ZM(J))  GO  TO  590 
IF  (J+l .GE. JFIN)  GO  TO  420 
IF  (ZM(J+1) .GE.2.0*ZM( J+2))  GO  TO  590 

COMBINE  ZONE  IF  ZONE  J  IS  NOT  TOO  HEAVY 

420  IF  (J.LE.2)  GO  TO  430 

IF  (ZM(J).GE.2.0*ZM(J-1))  GO  TO  590 
430  CONTINUE 

IF  (ZM( J) .GE.2.0*ZM( J+l))  GO  TO  590 

COMBINE  ZONE  (IF  NOT  ON  A  MATERIAL  BOUNDRY) 

DO  440  LM-l.NMTRLS 
IF  ( J.EQ. JBND(LM))  GO  TO  590 
440  CONTINUE 

COMBINE^tzONE  IF  NOT  AT  A  JEDIT  LOCATION 

IF  (NJEDIT.EQ.O)  GO  TO  460 
DO  450  LM-l.N JEDIT 
IF  (J.EQ.JEDIT(LM))  GO  TO  590 
450  CONTINUE 
460  CONTINUE 

COMBINE  ZONE  IF  NOT  ON  A  PHASE  OR  SPALL  BOUNDARY 

IF  (TSPALL(J) .NE.TSPALL( J+l))  GO  TO  590 
IF  (TSPALL(J) .EQ. 1 .234)  GO  TO  590 
IF  (TSPALL(J) .EQ.O. )  GO  TO  590 
IF  ( TSPALL( J+l ).EQ. 1.234)  GO  TO  590 
IF  (TSPALL( J+l) .EQ.O. )  GO  TO  590 
IF  ( JFIN. LE. 100)  GO  TO  590 
IF  (JDBG.EQ.l)  WRITE  (6,810) 

X(J)-X( J+l) 

H1«(ZM( J-1)+ZM( J))*U(J-1)+(ZM(J)+ZM( J+1))*U( J)+(ZM( J+l )+ZM( J+2) ) *U 
1  (J+l) 

Z1«ZM(J-1)+ZM(J)+ZM( J+l) 

Z2-ZM( J)+ZM( J+l )+ZM( J+2) 

A1-(ZM( J+2)+Zl)‘Zl 

A2-ZM( J-l ) *U( J-2 )  *Z2-ZM( J+2 ) *U( J+2 ) *Z1-H1 *(ZM(J-1)+Z1) 

E1-ZM( J-1)*(U( J-2)+U(J-l))*U(J-l)+ZM(J)*((U(J-l)+U( J) ) *U( J-l )+U( J) 

1  *U( J))+ZM(J+1)*((U(J)+U( J+1))*U(J)+U(J+1)*U( J+1))+ZM( J+2)*(U( J^-l) 

2  +U( J+2))*U( J+l) 

A3-H1 * ( HI +ZM( J+2 ) *  U( J+2 ) ) -Z2  *E1 
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UL—  .5*A2/A1 
UR-(H1-Z1*UL)/Z2 
DET-A2*A2-4. *A1*A3 
IF  (DET)  470,480,480 
470  CONTINUE 

UL  AND  UR  HAVE  COMPLEX  VALUES.  WE  MERELY  TAKE  THE  REAL  PART  OF 
UL  AND  UR  AND  CALCULATE  THE  RESULTING  NONCONSERVATION  OF  KINETIC 
ENERGY.  THIS  NONCONSERVATION  TERM  WILL  BE  ADDED  TO  THE  INTERNAL 
ENERGY  OF  THE  NEWLY  COMBINED  ZONE  TO  ENSURE  COMPLETE  CONSERVATION 
OF  ENERGY. 

DE«( El -( ZM( J-l )*U(J-2)+Zl *UL) *UL-( ZM( J)+ZM( J+l ) ) *UL‘UR-( ZM( J+2 ) *U 
1  ( J+2)+Z2*UR)*UR)/6. 

GO  TO  500 
480  CONTINUE 

UL  AND  UR  ARE  REAL.  HOWEVER  BOTH  UR  AND  UL  CAN  EACH  TAKE  ON  ONE 
OF  TWO  VALUES.  BOTH  PAIRS  OF  VALUES  SATISFY  BOTH  CONSERVATION  OF 
MOMENTUM  AND  CONSERVATION  OF  KINETIC  ENERGY.  THEREFORE  WE  SELECT 
THE  PAIR  OF  VALUES  WHICH  IS  CLOSEST  TO  THE  VALUES  OF  U(J-l)  AND 
U(J+1). 

U1-.5»SQRT(DET)/A1 
U2-Z1 *U1/Z2 

TEST«UL*U1+U2*U( J+l )-Ul *U( J-l )-UR*U2 

IF  (TEST . GT . 0 . )  GO  TO  490 

UL-UL+U1 

UR-UR-U2 

DE-0. 

GO  TO  500 
490  CONTINUE 
UL-UL-U1 
UR-UR+U2 
DE-0. 

500  CONTINUE 

ZMINV-1 .0/(ZM(J)+ZM(J+l)) 

E(J)-(E(J)*ZM(J)+E(J+1)*ZM(J+1 )+DE) *  ZMINV 
S( J)-(S(J)*ZM( J)+S( J+l) *ZMf J+l)) ‘ZMINV 
SD( J  )■( SD( J) *  ZM( J)+SD( J+l)* ZM (J+l))*  ZMINV 
SD2(  J  )  *(  SD2(  J  )  *ZM(  J).+SD2(  J+l )  *  ZM(  J+l  ))*  ZMINV 
QU( J)»(0U(J)*  ZM( J)+QU( J+l )*ZM(J+1))*  ZMINV 
VAMU(  J  )  «( VAMU(  J  )  *ZM(  J)+VAMU(  J-rl  )*ZM(J+1))  ‘ZMINV 
YY( J)-(YY(J)*ZM( J)+YY( J+l) *ZM( J+l)) ‘ZMINV 
ZZ( J)-(ZZ(J)»ZM(J)+ZZ( J+l) *ZM( J+l)) ‘ZMINV 
Q( J)-(Q( J)*ZM( J)+Q( J+l) *ZM( J+l) ) ‘ZMINV 
V( J)-(V( J) »ZM( J)+V( J+l) *ZM( J+l) ) ‘ZMINV 
DV( J)-(DV( J)*ZM(J)+DV( J+l)* ZM(J*1)) ‘ZMINV 
CS( J)-(CS(J)»ZM( J)+CS( J+l) *ZM( J+l)) ‘ZMINV 
QO( J)-(Q0(J)*ZM( J)+Q0( J+l) *ZM( J+l)) ‘ZMINV 
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YOZCJ)-CYOZCJ)*ZM( J)+YOZC J+l )* ZMC J+l )) ‘ZMINV 
EADDC J ) - ( £ADD( J ) * ZMC J ) +EADDC J+ 1 ) * ZMC J+l ) ) * ZMINV 
P( J)-C PC J) *ZMC J)+PC J+l )*ZMC J+l)) ‘ZMINV 
PX( J)-PX(J+1) 

PSMAXC J)-CPSMAX(J)»ZMCJ)+PSMAX( J+l )»ZMC J+l ))*ZMINV 
PSMINC J)-C PSMINC J)*ZMCJ)+PSMINC J+l) »ZMC J+l)) ‘ZMINV 
TEMP(J)-(TEMP(J)*ZM(J)+TEMP( J+l) *ZMC J+l)) ‘ZMINV 
ZFMCJ)-CZFMCJ)*ZM(J)+ZFM( J+l) ‘ZMC J+l)) ‘ZMINV 
EI( J)-(EI(J)‘ZM( J)+EI( J+l) *ZMC J+l)) ‘ZMINV 
F( J)-(F(J) *ZM(J)+F( J+l) ‘ZM( J+l)) ‘ZMINV 
NNN-NELEMCM) 

DO  510  NN-l.NNN 

ZF(NN, J)-(ZF(NN,J)»ZM(J)+ZF(NN, J+l) ‘ZM(  J+l)) ‘ZMINV 
510  CONTINUE 

DO  520  LL-l.NSPEC 

SSC J,LL)-(SS(J,LL)‘ZM(J)+SS( J+l ,LL)*ZM( J+l)) ‘ZMINV 
520  CONTINUE 

ZM( J )  -  ZMC J)+ZM( J+l ) 

U( J-1)«UL 
U( J)-UR 

SHIFT  ZONES  TO  THE  LEFT  AFTER  COMBINING  . . . 
JJJ-J+1 

DO  550  JJ-JJJ.JFIN 
X(JJ)-X(JJ+1) 

U(JJ)-U(JJ+1) 

ZM(JJ)-ZM(JJ+1) 

S(JJ)-S(JJ+1) 

SD( JJ)-SD( JJ+1) 

SD2( JJ)-SD2(JJ+1) 

QU( JJ)-QU(JJ+1) 

V AMU ( J J ) - V AMU ( JJ+1 ) 

YY( JJ)-YY(JJ+1) 

ZZ( JJ)-ZZ( JJ+1) 

Q( JJ)-QCJJ+1) 

V( JJ)-V( JJ+1) 

DV( JJ ) -DVC  JJ+1 ) 

CS(JJ)«CS( JJ+1 ) 

Q0( JJ)-QCC JJ+1) 

YOZC JJ)-YOZC JJ+1) 

EC JJ)-EC JJ+1) 

EADDC  JJ ) -EADDC  JJ+1 ) 

PC JJ)-P( JJ+1) 

PXC JJ)-PXCJJ+1) 

PSMAXC  JJ ) -PSMAXC  JJ+1 ) 

PSMINC  JJ) -PSMINC  JJ+1 ) 

TEMP  C  J J ) -TEMP ( JJ+1 ) 

TSPALLC  JJ ) -TSPALLC  JJ+1 ) 

ZFMC JJ)-ZFMC JJ+1 ) 
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EI( JJ)«EI(JJ+1) 

f( jj)-f(jj+i) 

NNN-NELEM(M) 

DO  530  NN-l.NNN 
ZF(NN, JJ)-ZF(NN, JJ+1) 

530  CONTINUE 

DO  540  LL-l.NSPEC 
SS( JJ,LL)-SS( JJ+1 ,LL) 

540  CONTINUE 
550  CONTINUE 

DO  560  LK-1 , NMTRLS 

IF  (JDBG.EQ.l)  WRITE  (6,740)  J , J , JBND(LM) 

IF  ( J.GT. JBND(LM) )  GO  TO  560 
IF  ( JBND(LM) .NE.O)  JBND(LM)-JBND(LM)-1 
IF  (JDBG.EQ.l)  WRITE  (6,740)  J , J , JBND(LM) 

560  CONTINUE 

IF  (NJEDIT.EQ.O)  GO  TO  580 
DO  570  LM-l.NJEDIT 
IF  (J.GT. JEDIT(LM))  GO  TO  570 
IF  (JEDIT(LM) .NE.O)  JEDIT(LM)-JEDIT(LM)-1 
570  CONTINUE 
580  CONTINUE 

IF  (J.LE.JHAT)  JHAT-JHAT-1 
IF  (J.LE.JSMAX)  JSMAX-JSMAX-1 
IF  (J.LE.JSTAR)  JSTAR-JSTAR-1 
IF  (J.LE.JTS)  JTS-JTS-1 
JFIN-JFIN-1 
590  CONTINUE 
J-J+l 
JJPRIN-J 

RETURN  TO  INITIAL  LOOP  THRU  MESH  TO  CHECK  FOR  COMBINE  AND  DIVIDE 

GO  TO  10 
600  CONTINUE 

IF  (JDBG.NE.l)  GO  TO  620 
DO  610  NJ-l.JFIN 
WRITE  (6,820)  NJ,X(NJ) 

610  CONTINUE 
620  CONTINUE 

J1 -MAXO ( JHAT , JSTAR ) 

MS-1 

SK2M1-1 . 1 *SK2M 
DO  640  J-2.J1 
DX-X( J)-X(J-l) 

IF  (TSPALL(J) .NE. 1 .234)  GO  TO  630 
MS-MS+1 

DX«XS(MS)-X( J-l ) 

630  CONTINUE 
*  IF  DEF.B64 
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SK2M1«AMAX1(CS( J)/DX,SK2M1) 

•ENDIF 

*  IF  DEF.B32 

SK2M1 -DMAX1 ( CS ( J ) / DX , SK2M1 ) 

•ENDIF 

640  CONTINUE 

*  IF  DEF.B64 

SK2M-AMAX1 C  SK2M , SK2M1 ) 

* ENDIF 
•IF  DEF.B32 

SK2M-DMAX1 ( SK2M , SK2M1 ) 

•ENDIF 

IF  (JDBG.EQ.l)  VTAPE-I.O 
CALL  EDIT 
RETURN 
C 

65C  FORMAT  (40H  SHIFT  ZONAL  PROPS  AFTER  DIVIDE...  JJ  -  ,16) 

660  FORMAT  (13H  **990  JFIN  -.17) 

670  FORMAT  (I4H  ***REZONE  J  -.16) 

680  FORMAT  (44H  AAA,  ARZCO .  SLIM,  DELS,  ADELS,  S(J),  SMAX  -.1P7E12.3/) 
690  FORMAT  (44H  **•  DISTRZ,  DTNH,  CS(J),  NREZON,  U(J),  AU  «,/5X,lP3Ell 
1  .3,17,1 P2E1 1.3/) 

700  FORMAT  (22H0  J,  L J ,  JFIN,  DELX  - , 317 , 1PE12 .4) 

710  FORMAT  (31H0  REZONE  TO  RIGHT  J,  JF,  LJ  -,3I7) 

720  FORMAT  (40H  DR.DL , V( J-l ) , V( J) ,V( J+l ) , ZMR, ZML , ZM( J)  /5X , 1P8E12 .4/ ) 
730  FORMAT  (43H  RZRL ,  RZRR,  XL.  XR,  UL,  UR,  TSPLLL,  TSPLLR/5X , 1P8E12 . 4 
1  /) 

740  FORMAT  (21H0  J,  LJ,  JBND(LM)  -.317) 

750  FORMAT  (30H  REZONE  LEFT  OF  GRADIENT  FROM, 15, 3H  TO, 15/) 

760  FORMAT  (12H  ***  LJ  -,I8) 

770  FORMAT  (18H  REZON  LEFT  LJ  -  ,I7,17H  JBND(LM)  -  .17) 

780  FORMAT  (39H  SHIFT  ZONE  PROP.  AFTER  DIVIDE..  JJ  -  ,16) 

790  FORMAT  (15H  COMBINE  J  -  ,I6,7H  X(J)  -.1PE12.4.9H  X(J+1)  «,1PE12. 
1  4/) 

800  FORMAT  (12H*****  JFIN  -,I6) 

810  FORMAT  (18H  COMBINE  TWO  ZONES/) 

820  FORMAT  (4H  J  -,I7,6H  X  -,E10.3) 

END 
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•DECK  SAHA 

SUBROUTINE  SAHA 
•IF  DEF.B32 

IMPLICIT  DQUBLEPRECISIONC A-H.O-Z) 

•ENDIF 

C 

REAL  LGDEL 
C 

•CALL  BLANK 
•CALL  AA 
•CALL  AC 
•CALL  EQFL 
•CALL  INDX 

DIMENSION  A(7 , 10) ,  RMAX(IO) 

THIS  ROUTINE  CALCULATES  THE  DEGREE  OF  IONIZATION  IN  THE  MESHES 
AND  THE  ENERGY  FLOW  ACROSS  MESH  BOUNDARIES  WHEN  GIVEN 
MESH  VOLUMES  AND  TEMPERATURES. 

DATA  A,  RMAX  /70*0 . . 10*0 . / 

IF  DEF.B64 

ZSTAR-AMAX1 ( ZFM( J ) , 1 .E-20) 

ENDIF 
IF  DEF.B32 

ZSTAR-DMAX1 ( ZFM( J ) , 1 .D-20) 

ENDIF 

XNATOM-6 . 02E23/ XMW( M) / V( J) 

FXPC-2 . 43E 1 5 • TEMP ( J ) • • 1 . 5 / XNATOM 
IF  (FXPC.GT.1.0)  GO  TO  20 

HERE  WE  MAKE  A  ROUGH  GUESS  AT  THE  VALUE  OF  THE  IONIZATION 
WHEN  IT  IS  SMALL 

ZSTAR-0 . 0 
DO  10  Nl-l.NEM 
N-IELEM(M.Nl) 

AVOID  EXP  UNDERFLOW 

ARGEXP— XI(N,  l)/8.64E-5/TEMP(J) 

EXPR-0 . 0 

IF  ( ARGEXP . GT . -675 . )  EXPR-EXP( ARGEXP) 

10  ZSTAR-ZSTAR+SQRTC FXPC*EXPR) * AF(M , N ) *FL0AT( NATOM(M) ) 

FOR  LARGER  IONIZATIONS  THE  GUESSED  VALUE  IS  TAKEN  AS  THE  LAST 
VALUE  —  ZFM(J) 

20  MCOUNT-O 
NPLUS-0 

DO  30  Nl-l.NEM 
N-IELEM(M.Nl) 
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30  IPLUS0(N)-0 
40  NCHNG-1 
ZSTAR1-1.0 

FIND  8  LEVELS  -  K  -  OF  IONIZATION  -  NI(K,N)  -  FOR  EACH  ELEMENT 
-  N  -  OCCURRING  IN  MATERIAL  M  AND  FIND  THE  RATIOS  OF  THE  POPULA 
TIONS  -  A(K.N)  -  IN  THESE  LEVELS 

DO  80  Nl-l.NEM 
N-IELEM(M.Nl) 

CHANGE  IN  KMAX  TO  INCLUDE  GROUND  STATE  AS  ONE  OF  THE  POSSIBLE 
IONIZATION  STATES 

KMAX(N)-MIN0(NTBL(N)+1 .8) 

KN-KMAX(N) 

IPLUS(N)-0 
IF  DEF.B64 

IZF-IFIX(ZF(N,J))-KN/2 

END  IF 

IF  DEF.B32 

IZF-IDINT(ZF(N, J))-KN/2 

ENDIF 

IZF-MAXO(IZF.-l) 

IZF-MINO(IZF.NTBL(N)-KN) 

DO  50  K-l.KN 
50  NI(K.N)-IZF+K 

IF  ( J . LE . JTS . ANT . XPRIN . EQ .  1 )  WRITE  (6,220)  N, (NI(K,N) ,K-1 , 8) 

KGO-KN-1 

KGO-MAXO ( KGO , 1 ) 

DO  70  K-l.KGO 
L-NI(K,N)+1 

AXI-XI(N.L)/(8.64E-5*TEMP(J)) 

IF  (AX1 .LT.200. )  GO  TO  60 
A(K,N)-0. 

GO  TO  70 

60  A( K,N)«FXPC*EXP( -AX1 ) 

70  IF  ( KPRIN . EQ . 1 . AND . J . EQ . JTS )  WRITE  (6,230)  MATL(M) ,NAMEL(N) ,NI(X,N 
1  ) , KGO ,KN,L,J,XI(N,L), TEMP ( J ) ,A(K,N) ,FXPC 
80  CONTINUE 

FIND  FRACTION  OF  ATOMS  -  R(K,N)  -  IN  EACH  LEVEL  -  K  -  AND  THE 
LARGEST  FRACTION  IN  EACH  ELEMENT 

90  DO  150  Nl-l.NEM 
N-IELEM(M.Nl) 

KN-KMAX(N) 

KGO-KN-1 

IF  (KN.LE.2)  GO  TO  100 
GO  TO  110 
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100  CONTINUE 
R(l,N)-0. 

A( 1 ,N)-A( 1 ,N)/ZSTAR*ZSTAR1 

IF  (A(l.N).GT.C.  R( 1 ,N)-0 . 5*A( 1 ,N) * (SQRT( l.+4./A(l,N))-l.) 

IF  (A(l ,N).GT.l . .  AND.RU  ,N)  .EQ.O.  )  R(1,N)-1. 

R(2,N)-R(1,N) 

RMAX(N)«R(1 ,N) 

IF  (KPRIN.EQ. 1 .AND. J.EQ. JTS)  WRITE  (6,240)  NAMEL(N) . ZSTAR, ZSTAR1 
1  .  KN , KGO , A( 1 , N) 

GO  TO  150 
110  CONTINUE 

DO  120  K-l.KGO 
A(K,N)-A(K,N)/ZSTAR*ZSTAR1 

IF  ( KPRIN . EQ . 1 . AND .J.EQ. JTS )  WRITE  (6,240)  NAMEL(N) , ZSTAR, ZSTARI 
1  ,KN,KGO,A(K,N) 

120  CONTINUE 

R(l,N)-A(KGO,N) 

DO  130  K-2.KGO 
KGOl-KN-K 

R( 1 , N) »A(KG01 ,N) * ( 1 . 0+R( 1 , N) ) 

IF  (KPRIN. EQ.l. AND. J.EQ. JTS)  WRITE  (6,250)  NAMEL(N) ,KG01 ,K, ACKGOl 
1  , N) ,R( 1 ,N) 

130  CONTINUE 

R(1,N)-1./(1.+R(1,N)) 

RMAX(N)-R(1,N) 

IF  (KPRIN. EQ.l. AND. J.EQ. JTS)  WRITE  (6,260)  NAMEL(N) ,R(1 ,N) ,RMAX(N) 
DO  140  K-2.KN 
R(K,N)-A(K-1 ,N)*R(K-1 ,N) 

IF  (KPRIN.EQ. 1)  WRITE  (6,270)  NAMEL(N) , K, A(K-1 ,N) ,R(K-1 ,N) ,R(K,N) 
140  IF  (R(K,N) . GT .RMAX(N) )  RMAX(N)-R(K,N) 

150  RMAX(N)-0.1*RMAX(N) 

SET  OLD  IONIZATION  EQUAL  TO  ZSTARI  AND  CALCULATE  A  NEW  VALUE 
FOR  EACH  ELEMENT  -  ZF1(N)  -  AND  A  NEW  TOTAL  VALUE 

ZSTARI -ZSTAR 
ZSTAR-0 .0 
DO  170  Nl-l.NEM 
N-IELEM(M.Nl) 

KN-KMAX(N) 

ZF1 ( N )-Q . 0 
DO  160  K-l.KN 

160  ZFl(N)-ZFi(N)-t-R(K,N)  mFL0AT(  NI  (  K  ,N)  ) 

1 70  ZSTAR-ZSTAR+AF(M , N ) * ZF1 ( N ) *  FLOAT ( N ATOM ( M ) ) 

IF  NEW  AND  OLD  VALUES  OF  TOTAL  IONIZATION  DIFFER  BY  LESS  THAN 
1  PERCENT  NEW  VALUE  IS  OK  -  ELSE  A  VALUE  OF  0.5  *  ( ZNEW  +  ZOLD) 

IS  USED  AND  THE  CALCULATION  REPEATED 

MCOUNT - MCOUNT+ 1 
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I?  ( MCOUNT . GT .100)  GO  TO  180 
IF  ( MCOUNT . GT . 500 )  GO  TO  210 

IF  (ABS( ZSTAR-ZSTAR1 ) . LT .0.01 *ZSTAR1 )  GO  TO  180 
IF  ( ZSTAR. LT.l.E-40)  GO  TO  210 
ZSTAR- ( ZSTAR+ZSTAR1 ) / 2 . 0 
GO  TO  90 

CHECK  TO  SEE  IF  LARGEST  POSSIBLE  EIGHT  IONIZATION  LEVELS  HAVE  BEEN 
CHOSEN  FOR  EACH  ELEMENT  -  IF  NOT  POOREST  CHOSEN  ELEMENT  NUMBER 
IS  TAGGED  NC 

180  XMAX1-0.0 

DO  190  Nl-l.NEM 
N-IELEM(M,N1) 

KN-KMAX(N) 

IF  (KN.EQ.l)  GO  TO  190 

IF  (FLOAT(NI(l,N))*R(l.N).GT.FLOAT(NI(KN-l,N))*R(KN-l,N).AND.NI(l 
1  ,N)  .GT.O)  IPLUS(N)  — 1 

IF  (FLOAT(NI(KN,N))*R(KN.N) . GT . FLOATC NI (2,N))*R(2,N) . AND.NI(KN ,N) 

1  . LT.NTBL(N) )  IPLUS(N)-1 

IF  ( IPLUS(N) .  EQ .  0 .OR . IPLUS(N)+IPLUSO(N) . EQ . 0)  GO  TO  190 
NCHNG-2 

XMAX-ABS ( ZF1 (N)-ZF(N , J) ) 

IF  (XMAX.LT.XMAX1)  GO  TO  190 
XMAX1-XMAX 
NC-N 

190  CONTINUE 

IONIZATION  LEVELS  IN  ELEMENT  NC  ARE  UPGRADED  OR  DOWNGRADED  BY  1 
AND  THE  ENTIRE  CALCULATION  OF  ZFM(J)  IS  REDONE 

GO  TO  (210.200),  NCHNG 
CALL  GOTOER 

200  ZF ( NC , J ) - ZF ( NC , J ) +FLOAT ( I PLUS ( NC ) ) 

NPLUS-NPLUS+1 
I PLUSO ( NC ) - I PLUS ( NC ) 

GO  TO  40 
210  RETURN 
C 

220  FORMAT  ( ' ONI ' , 15/ ( IX , 1015 ) ) 

230  FORMAT  ('0  SAHA ’ . 2( X , A10 ) , '  NI(X,N)  -’,13,'  KGO  -',13,'  KN  -',13.' 

1  L  -',13.'  J  -'.13,'  XI(N.L)  - ' , 1PE10 . 3 , '  TEMP(J)  « ' . 1PE10 . 3 , / 10X . 

2  '  A(K , N )  - ' , 1PE10 . 3 ,  FXPC  -'.1PE10.3/) 

240  FORMAT  (0  SAHA  '.A10,'  ZSTAR  -'.1PE10.3,'  ZSTAR1  -’.1PE10.3.'  KN 
1-  ,13.'  KGO  -',13,'  A(K,N)  -'.1PE10.3/) 

250  FORMAT  (0  SAHA  ',A10,'  KG01  -',13,'  K  -',13,'  A(KG01,N)  -'.1PE10. 
1  3.  R( 1 , N)  -' , 1PE10 . 3/ ) 

260  FORMAT  (0  SAHA  ',A10,'  R(1,N),  RMAX(N)  - ' , 1P2E10 . 3/ ) 

270  FORMAT  (0  SAHA  '.A10,'  K,  A(K-1,N),  R(K-1,N).  R(K,N)  -',I3,1?3E10 
1  .3/) 
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‘DECK  SPALL 

SUBROUTINE  SPALL 
•IF  DEF.B32 

IMPLICIT  D0U3LEPRECISI0N( A-H.O-Z) 

•ENDIF 

C 

‘CALL  BLANK 
•CALL  SPLLC 
El-O. 

LL-1 
M-l 
MS-1 
SMAX-O. 

TMAX-O. 

DO  340  J-2.JFIN 

CHANGE  MATERIAL  INDEX  AND  ADD  NEW  ACTIVE  ZONE 

IF  ( J-JBND(M) )  20,10,20 
10  CONTINUE 
LL-LL+1 
20  CONTINUE 

IF  (J.LT.JFIN)  GO  TO  30 
GO  TO  340 

CHECK  FOR  PREVIOUSLY  SPALLED  ZONE 
30  CONTINUE 

IF  (TSPALL(J).EQ. 1.234)  GO  TO  40 
GO  TO  70 
40  CONTINUE 
I SPALL-3 

NOW  CHECK  TO  SEE  IF  ZONE  SHOULD  BE  RECOMBINED 
IF  (  XS  (  MS  )  .  LT .  X(  J  )  )  GO  TO  70 
YES,  RECOMBINE  ZONE 

U( J)-(U( J)*ZM( J+l)+US(MS)*ZM(J))/(ZM(J)+ZM( J+l)) 
X( J)-X( J)+(XS(MS)-X( J))‘ZM( J)/(ZM( J)+ZM( jTi  )  ) 
DU-U( J) -U( J-l ) 

V( J)-(X( J)-X( J-1))/ZM(J) 

ISM-ISM-1 

IF  (MS-1 .EQ. ISM)  GO  TO  60 
DO  50  I -MS. ISM 
IP1-I+1 
XS(I)-XS(IP1) 

US(I)-US(IP1) 
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50  CONTINUE 
60  CONTINUE 

TSPALL(J)-0.0 
I SPALL- 1 
ISMP1-ISM+1 
ZS( ISMP1 )-0 . 0 
US( ISMPI )-0 . 0 

WRITE  (6,410)  J , X( J) , N .TIME 
LINE-LINE -f2 

IF  (LINE. LE. 50)  GO  TO  70 
WRITE  (6,440) 

LINE-0 
70  CONTINUE 

IF  (V(J) .LT.0.0)  WRITE  (6,430)  J .MS , N , XS(MS) , X( J) ,X( J-l ) , TSPALL( J) 

NOW  CHECK  FOR  TENSION  IN  VAPOR  AND  MELT 

IF  (TSPALL( J) .EQ.8. )  GO  TO  290 
IF  (TSPALL(J) .EQ.7. )  GO  TO  80 

IF  (TSPALL(J-l) .NE.7. . AND . TSPALL( J-l) .NE.8. )  GO  TO  100 
IF  (TSPALL(J).EQ. 1.234. OR. TSPALL(J).EQ. 0.0)  GO  TO  90 
GO  TO  100 
80  CONTINUE 

IF  (TSPALL( J+l ) .EQ.7.)  GO  TO  90 

IF  (TSPALL( J+l). EQ. 1.234. OR. TSPALL( J+l ) . EQ . 0.0)  GO  TO  90 
GO  TO  100 
90  CONTINUE 
IF  DEF.B64 

S( J)-AMAX1(S(J) .0. ) 

ENDIF 
rr  nrp 

S(J)«DMAX1(S(J) ,0 .DO) 

ENDIF 

GO  TO  290 

CHECK  FOR  FRACTURE  IN  SOLID  MATERIAL 
100  CONTINUE 

IF  (S(J)+Q(J) .GE.O. ,OR.S(J-l)*Q(J-l) .GE.O. )  GO  TO  290 
IF  (TSPALL(J-l) .EQ.8. )  GO  TO  290 

IF  (TSPALL( J) . EQ . 1 . 234 .OR . TSPALL( J) . EQ . 0 . )  GO  TO  290 

IF  (ISPALL.NE.O.OR.TSPALL( J-l) .EQ. 1 .234)  GO  TO  290 

GO  TO  (110,120,130,140,150,160,170,180,190,200),  ISPLLM(M) 

CALL  GOTOER 
110  CONTINUE 

FRACTURE  MODEL  BASED  ON  TENSION.  CALCULATE  STRESS  FOR  COMPARISON 
WITH  TSPALL. 

SJ-((S(J)+Q(J))»ZM(J)+(S(J-1)+Q(J-1))*ZM(J-1))/(ZM(J)+ZM(J-1)) 
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IF  (TSPALL(J-l)+SJ.GE.O.  )  GO  TO  290 
IF  (MS.LE.49)  GO  TO  210 
WRITE  (6,450) 

STOP  21 
120  CONTINUE 

SIMPLE  STRAIN  MODEL  FOR  FRACTURE.  SJ  -  AVERAGE  STRAIN. 

E2-V( J)*RHO(M) 

E2-1 . /E2-1 . 

SJ-.5*(E1+E2) 

E1-E2 

IF  (TSPALLC  J-D+SJ.GE.O.  )  GO  TO  290 
IF  (MS.LE.49)  GO  TO  210 
WRITE  (6.450) 

STOP  21 
130  CONTINUE 
140  CONTINUE 
150  CONTINUE 
160  CONTINUE 
170  CONTINUE 
180  CONTINUE 
190  CONTINUE 
200  CONTINUE 
GO  TO  290 
210  CONTINUE 
ISM-ISM+1 
II-ISM 
JS-J-1 
XCAL-0 . 

SUMASS-0 . 

TSUMAS-0 . 

M-l 

DO  250  I-2.JFIN 
IF  (I-JS)  220.230,260 
220  CONTINUE 

IF  ( J3ND( M ) . EQ . 0 )  GO  TO  240 
IF  ( I-JBND(M) )  240,230,230 
230  CONTINUE 

TSUMAS«TSUMAS+ZM( I ) 

TCAL-TSUMAS/RHO ( M ) 

XCAL-XCAL+TCAL 

SUMASS-SUMASS+TSUMAS 

TSUMAS-O. 

M-M+l 
GO  TO  250 
240  CONTINUE 

TS*JMAS-TSUMAS+ZM(  I ) 

250  CONTINUE 
260  CONTINUE 
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WRITE  (6.400)  JS ,  X(  JS  ) ,N .TIME , SJ , TSPALLC JS ) ,  XCAL , SUMASS . ISM 
IF  (TSPALL( JS ) . EQ . 7 . .OR. TSPALLC JS-1 ) . EQ . 7 . )  S(JS)-0. 

TSPALLC  JS ) - 1 . 234 

IF  (TSPALLC JS-1 ) . EQ . 8 . . OR .TSPALLC J ) . NE . 7 . )  IS-1 
LINE-LINE +3 

IF  (LINE.LT. 150)  GO  TO  280 
WRITE  (6.440) 

LINE-0 
GO  TO  280 
270  CONTINUE 
III-II-l 
XSCII)-XS(III) 

USCII)-US(III) 

II-III 

280  CONTINUE 

IF  (II.GT.MS)  GO  TO  270 
XSCMS)-X(JS) 

USCMS)-U(JS) 

I SPALL-2 
290  CONTINUE 

CALCULATE  TMAX  AND  SMAX 

SJ-SCJ) 

IF  (SJ-TMAX)  300.310.310 
300  CONTINUE 
TMAX-SJ 
JTMAX-J 
310  CONTINUE 

IF  (SJ-SMAX)  330.330.320 
320  CONTINUE 
SMAX-SJ 
JSMAX-J 
330  CONTINUE 

IF  ( I SPALL. GE .2)  MS-MS+1 

ISPALL-0 

M-LL 

340  CONTINUE 

IF  (IS.LE.O)  RETURN 
IS-0 
1-0 
MS-1 
SMM-0 

DO  380  J-2.JFIN 

IF  (TSPALLC J) .NE. 1 .234)  GO  TO  350 
SMM-SMM+. 5*ZM( J)*(U( J-l )+US(MS)) 

MS-MS+1 
GO  TO  360 
35C  CONTINUE 

SMM-SMM+ .5*ZM(J)*(U(J-1)+U(J)) 
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360  CONTINUE 

IF  (J.EQ.JFIN)  GO  TO  370 

IF  (TSPALL(J) .EQ.8. . AND . TSPALLC J+l ). NE . 8 . )  GO  TO  370 
IF  ( TSPALLC J).NE. 1.234)  GO  TO  380 
370  CONTINUE 
I-I+l 
SM(I)-SMM 
SMM-O. 

380  CONTINUE 

WRITE  (6,420)  (SM( J) , J-l , I) 

I-I/8 

LINE-LINE+I+3 

IF  (LINE. LE. 50)  GO  TO  390 

WRITE  (6,440) 

LINE-0 
390  CONTINUE 
RETURN 
C 

400  FORMAT  (/27H  —  SPALL  OCCURED  AT  ZONE, 14, 9H  LOCATION , 1PE12 . 4 . 12H 

1  CM  AT  CYCLE, 14. 6H  TIME- , 1PE11 . 4 , 1 1H  SEC  SJ  - , 1PE1 1 . 4 . 1 1H  TSPALL 
2( J)» , 1PE11 .4/5X.20HLOCATI0N  IN  MATERIAL , 21H  COORDINATE  SYSTEM  IS . 1 
3  PE12.4.23H  CM  TOTAL  MASS  TO  THIS , 8H  POINT  - , 1PE1 1 .4 , 26H  GM  TOTA 
4L  NO  OF  SPALLS  IS, 13) 

410  FORMAT  (/19H  $$$  COMBINED  ZONE, 14, 9H  LOCATION , 1PE12 .4 . 13H  CM  AT 

1 CYCLE, 14 ,6H  TIME- , 1PE11 .4 ,4H  SEC) 

420  FORMAT  (/24H  MOMENTUM  AFTER  FRACTURE/ (1P8E14 . 4) ) 

430  FORMAT  (23H  NEGATIVE  DENSITY  ZONE, 14, 5H  MS-.I3.10H  CYCLE  NO, 14/ 
1  9H  XS(MS)- , 1PE14 .4 , 7H  X( J)«, 1PE14.4.9H  X( J-l). , 1PE14 .4, 12H  TSP 
2ALL(J)  ■ , 1PE14 .4) 

440  FORMAT  (1H1) 

450  FORMAT  (/51H  PROGRAM  HAS  REACHED  THE  NO  OF  SPALLS  DIMENSIONED) 
END 
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•DECK  TRANSP 

SUBROUTINE  TRANSP 
•IF  DEF.B32 

IMPLICIT  DOUBLEPRECIS ION ( A-H , 0- Z ) 

•ENDIF 
•CALL  BLANK 
•CALL  AA 
•CALL  AC 
•CALL  EQFL 
•CALL  INDX 
M-l 
LL-1 

NEM-NELEMC 1 ) 

J1 -MAXO ( JSTAR . JHAT) 

JI-MINOCJl , JFIN) 

DO  50  J-2.J1 

IF  ( J.EQ. JBND(M))  LL-M+1 
IF  (ITER(J) .EQ.O)  GO  TO  40 
XLAM1(J)«0.0 
XLAM2( J)-0 . 0 

IF  (ZFM(J) .LT.0.01)  GO  TO  40 
IF  (ITER(J) .EQ. 1)  GO  TO  20 
Zl-0.0 
Z2-0.0 

DO  10  Nl-l.NEM 

N-IELEM(M,Nn 

Z1-Z1+AF(M,N)‘ZF(N,J) 

10  Z2«Z2+AF(M,N)*ZF(N, J)**2 

XLAM1 ( J) -3 . 18E-6*Z1/Z2/LGDEL(M)/TEMP( J) **0.5 
IF  (ITER( J) . EQ.2)  GO  TO  40 
20  IF  (ZFM(J) .LT.l .0)  GO  TO  40 
XLAMA-O. 

XL  AMP- 1 . 

C 

C  NOW  WE  CALCULATE  THE  ROSELAND  KEAN  OPACITY  TO  BE  STORED  IN  XLAM2CJ 
C 

DO  30  Nl-l.NEM 
N-IELEM(M.Nl) 

•IF  DEF.B64 

Z1 -AMAX1 ( ZF(N , J) . 1 .E-30) 

•ENDIF 
•IF  DEF.B32 

Z1 -DMAX1 C  ZF(N , J) , 1 . D-30) 

•ENDIF 

Z2-Z1 *Z1+ . 25 

XLAMT-5 . BE -26* ( XMW(M) • V( J) / FL0AT(NAT0M(M) ) /AF(M.N))*  *2*TEMP( J) • • 3 . 
1  5/Z1/Z2 
XLAMP-XLAMP  *  XLAMT 
30  XLAMA-XLAMA+ XLAMT 
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IF  (NEM.EQ.l)  XLAMA-1.0 
XLAMP-XLAMP/XLAMA*7 . 56E-5 
XLAM2( J)-XLAMP 
40  M-LL 

NEM-NELEM(M) 

50  CONTINUE 
RETURN 

END 
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HYPUF  CORRECTION  DECK 

•ID  RUN 
‘DEFINE  B32 
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HYPUF  INPUT  INSTRUCTIONS 


The  attached  table  gives  the  input  instructions  for  HYPUF  in  the  form  of  a  logic 
flow  diagram.  With  the  exception  of  those  variables  which  require  character  input,  all 
input  is  in  free  format.  The  variables  that  require  character  input  are  so  designated  in 
the  instruction  table  (e.g.,  by  :  A10). 

The  user  should  be  aware  that  one  disadvantage  of  free  format  input  is  that 
something  must  be  entered  for  every  variable  requested.  Simply  leaving  the  fields 
blank  will  not  work.  If  an  input  should  be  zero,  than  enter  0.  The  input  for  a  sample 
problem  is  provided  following  the  input  instructions  table. 

Following  the  sample  problem  input  listing  is  a  set  of  three  graphs  which 
summarize  the  calculated  results  for  the  sample  problem,  the  first  graph  shows  the 
time  evolution  of  two  measures  of  specific  impulse  which  are  calculated  by  the  code. 
The  specific  impulse  history  is  printed  out  on  tape  9  (also  known  as  FORTRAN  Unit  9). 
A  spreadsheet  program  was  used  to  select  the  columns  from  the  printout  that  were 
plotted.  The  second  graph  shows  the  calculated  stress  history  at  the  midplane  of  the 
material.  The  last  graph  show  the  peak  stress  calculated  as  a  function  of  position. 
Compressive  stresses  are  positive  in  HYPUF.  The  sample  problem  given  should  be 
adequate  for  verifying  the  installation  of  HYPUF  on  a  given  computer  system. 
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***  F300  /  TCWP  #** 


15  11110  0 

l.E-10  5.E-10  l.E-9  2.E-9  5.1E-9 

1  1  . 

-1  2  50  40  20  0  0  50000 

.1  .125  0. 

5.  3.0E-6  0.  .02  0.  10  0  1 

l.E-12  .5  .5 

4 

2  4  4  4 

HYDROGEN 

1  0  i . 0079 

IS. 01  -3.006  .014 

0.  0.  300. 

CARBON 

6  0  12.0111 
21.77  -2.843  .005 

39.93  -2.843  .013 

2191.3  -2.436  .284 

0.  0.  300. 

NITROGEN 
7  0  14.0067 

72.76  -2.791  .007 

45.64  -2.791  .018 

2967.  -2.701  .4 
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0.  0.  300 


OXYGEN 

8  0  15.9994 

150.7  -2.707  .009 

85.6  -2.707  .024 

3619.  -2.768  .533 

0.  0.  300. 

TCWP 
0  1 

1.44  1.59E11  1.94E11  1.113E10  .52  .11  0.  -1 .E9  1  205. 

6*0 . 

3.16E9  3.1E10  0.  4.S1E-2  12.085  5.  5.E3 

6*0 
4 

12  3  4 

.0229  .8915  .0077  .0779 

TCWP 
0  1 

1.44  1.59E11  1.94E11  1.113E10  .52  .11  0.  -1.E9  1  205. 

6*0. 

3.16E9  3. IE  10  0.  4.81E-2  12.085  5.  5.E3 

6*0 

4 

12  3  4 

.0229  .8915  .0077  .0779 

2  1 
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